├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.lhs ├── cabal.project ├── dependent-map.cabal └── src └── Data └── Dependent ├── Map.hs └── Map ├── Internal.hs ├── Lens.hs ├── PtrEquality.hs └── Typeable.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--distribution' 'focal' 'dependent-map.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20240708 12 | # 13 | # REGENDATA ("0.19.20240708",["github","--distribution","focal","dependent-map.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:focal 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.10.1 32 | compilerKind: ghc 33 | compilerVersion: 9.10.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.8.2 37 | compilerKind: ghc 38 | compilerVersion: 9.8.2 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.6.5 42 | compilerKind: ghc 43 | compilerVersion: 9.6.5 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.4.8 47 | compilerKind: ghc 48 | compilerVersion: 9.4.8 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.2.8 52 | compilerKind: ghc 53 | compilerVersion: 9.2.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.0.2 57 | compilerKind: ghc 58 | compilerVersion: 9.0.2 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-8.10.7 62 | compilerKind: ghc 63 | compilerVersion: 8.10.7 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.8.4 67 | compilerKind: ghc 68 | compilerVersion: 8.8.4 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.6.5 72 | compilerKind: ghc 73 | compilerVersion: 8.6.5 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.4.4 77 | compilerKind: ghc 78 | compilerVersion: 8.4.4 79 | setup-method: ghcup 80 | allow-failure: false 81 | fail-fast: false 82 | steps: 83 | - name: apt 84 | run: | 85 | apt-get update 86 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 87 | mkdir -p "$HOME/.ghcup/bin" 88 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 89 | chmod a+x "$HOME/.ghcup/bin/ghcup" 90 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 91 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 92 | env: 93 | HCKIND: ${{ matrix.compilerKind }} 94 | HCNAME: ${{ matrix.compiler }} 95 | HCVER: ${{ matrix.compilerVersion }} 96 | - name: Set PATH and environment variables 97 | run: | 98 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 99 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 100 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 101 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 102 | HCDIR=/opt/$HCKIND/$HCVER 103 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 104 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 105 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 106 | echo "HC=$HC" >> "$GITHUB_ENV" 107 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 108 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 109 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 110 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 111 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 112 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 113 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 114 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 115 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 116 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 117 | env: 118 | HCKIND: ${{ matrix.compilerKind }} 119 | HCNAME: ${{ matrix.compiler }} 120 | HCVER: ${{ matrix.compilerVersion }} 121 | - name: env 122 | run: | 123 | env 124 | - name: write cabal config 125 | run: | 126 | mkdir -p $CABAL_DIR 127 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 160 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 161 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 162 | rm -f cabal-plan.xz 163 | chmod a+x $HOME/.cabal/bin/cabal-plan 164 | cabal-plan --version 165 | - name: checkout 166 | uses: actions/checkout@v4 167 | with: 168 | path: source 169 | - name: initial cabal.project for sdist 170 | run: | 171 | touch cabal.project 172 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 173 | cat cabal.project 174 | - name: sdist 175 | run: | 176 | mkdir -p sdist 177 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 178 | - name: unpack 179 | run: | 180 | mkdir -p unpacked 181 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 182 | - name: generate cabal.project 183 | run: | 184 | PKGDIR_dependent_map="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/dependent-map-[0-9.]*')" 185 | echo "PKGDIR_dependent_map=${PKGDIR_dependent_map}" >> "$GITHUB_ENV" 186 | rm -f cabal.project cabal.project.local 187 | touch cabal.project 188 | touch cabal.project.local 189 | echo "packages: ${PKGDIR_dependent_map}" >> cabal.project 190 | echo "package dependent-map" >> cabal.project 191 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 192 | cat >> cabal.project <> cabal.project.local 195 | cat cabal.project 196 | cat cabal.project.local 197 | - name: dump install plan 198 | run: | 199 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 200 | cabal-plan 201 | - name: restore cache 202 | uses: actions/cache/restore@v4 203 | with: 204 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 205 | path: ~/.cabal/store 206 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 207 | - name: install dependencies 208 | run: | 209 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 210 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 211 | - name: build w/o tests 212 | run: | 213 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 214 | - name: build 215 | run: | 216 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 217 | - name: cabal check 218 | run: | 219 | cd ${PKGDIR_dependent_map} || false 220 | ${CABAL} -vnormal check 221 | - name: haddock 222 | run: | 223 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 224 | - name: unconstrained build 225 | run: | 226 | rm -f cabal.project.local 227 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 228 | - name: save cache 229 | uses: actions/cache/save@v4 230 | if: always() 231 | with: 232 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 233 | path: ~/.cabal/store 234 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ############## 2 | # Global/OSX # 3 | ############## 4 | 5 | .DS_Store 6 | Icon? 7 | 8 | # Thumbnails 9 | ._* 10 | 11 | # Files that might appear on external disk 12 | .Spotlight-V100 13 | .Trashes 14 | 15 | 16 | ########### 17 | # Haskell # 18 | ########### 19 | 20 | dist/ 21 | dist-newstyle/ 22 | *.o 23 | *.hi 24 | *.chi 25 | *.chs.h 26 | .cabal-sandbox 27 | cabal.sandbox.config 28 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for dependent-map 2 | 3 | ## Unreleased (0.4.0.1) 4 | 5 | * Minimum `base` version is now `4.11` (GHC 8.4.x). 6 | * Use canonical `mappend`/`(<>)` definitions. 7 | 8 | ## 0.4.0.0 - 2020-03-26 9 | 10 | * Stop re-exporting `Some(..)`, `GCompare(..)`, and `GOrdering(..)` from `dependent-sum` (which itself re-exports from `some` in some versions). 11 | * Stop re-exporting `DSum(..)` from `dependent-sum`. 12 | 13 | ## 0.3.1.0 - 2020-03-26 14 | 15 | * Drop support for non-GHC compilers. 16 | * Drop support for GHC < 8. 17 | * Update maintainer and GitHub links. 18 | * Support `dependent-sum` 0.7. 19 | * Add `ffor`, `fforWithKey`, `forWithKey`, `forWithKey_`, and `traverseWithKey_` to `Data.Dependent.Map`. 20 | * Enable `PolyKinds` for `Data.Dependent.Map.Lens`. 21 | 22 | ## 0.3 - 2019-03-21 23 | 24 | * Change instances of Eq, Ord, Read, Show to use Has' from constraints-extras instead of *Tag classes. 25 | * This ends support for GHC 7.x. 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This library (dependent-maps) is derived from code from the 2 | containers library. I have no idea which, if any, of the following 3 | licenses apply, so I've copied them all. Any modifications by myself 4 | I release into the public domain, because in my opinion the concept of 5 | owning information (ownership being a prerequisite to licensing) is 6 | pretty silly in the first place. And, from a practical standpoint, 7 | the proliferation of legalese that must be attached to every piece of 8 | software of any appreciable size is actually quite obscene already. 9 | 10 | ----------------------------------------------------------------------------- 11 | 12 | This library (libraries/containers) is derived from code from several 13 | sources: 14 | 15 | * Code from the GHC project which is largely (c) The University of 16 | Glasgow, and distributable under a BSD-style license (see below), 17 | 18 | * Code from the Haskell 98 Report which is (c) Simon Peyton Jones 19 | and freely redistributable (but see the full license for 20 | restrictions). 21 | 22 | * Code from the Haskell Foreign Function Interface specification, 23 | which is (c) Manuel M. T. Chakravarty and freely redistributable 24 | (but see the full license for restrictions). 25 | 26 | The full text of these licenses is reproduced below. All of the 27 | licenses are BSD-style or compatible. 28 | 29 | ----------------------------------------------------------------------------- 30 | 31 | The Glasgow Haskell Compiler License 32 | 33 | Copyright 2004, The University Court of the University of Glasgow. 34 | All rights reserved. 35 | 36 | Redistribution and use in source and binary forms, with or without 37 | modification, are permitted provided that the following conditions are met: 38 | 39 | - Redistributions of source code must retain the above copyright notice, 40 | this list of conditions and the following disclaimer. 41 | 42 | - Redistributions in binary form must reproduce the above copyright notice, 43 | this list of conditions and the following disclaimer in the documentation 44 | and/or other materials provided with the distribution. 45 | 46 | - Neither name of the University nor the names of its contributors may be 47 | used to endorse or promote products derived from this software without 48 | specific prior written permission. 49 | 50 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 51 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 52 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 53 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 54 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 55 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 56 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 57 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 58 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 59 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 60 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 61 | DAMAGE. 62 | 63 | ----------------------------------------------------------------------------- 64 | 65 | Code derived from the document "Report on the Programming Language 66 | Haskell 98", is distributed under the following license: 67 | 68 | Copyright (c) 2002 Simon Peyton Jones 69 | 70 | The authors intend this Report to belong to the entire Haskell 71 | community, and so we grant permission to copy and distribute it for 72 | any purpose, provided that it is reproduced in its entirety, 73 | including this Notice. Modified versions of this Report may also be 74 | copied and distributed for any purpose, provided that the modified 75 | version is clearly presented as such, and that it does not claim to 76 | be a definition of the Haskell 98 Language. 77 | 78 | ----------------------------------------------------------------------------- 79 | 80 | Code derived from the document "The Haskell 98 Foreign Function 81 | Interface, An Addendum to the Haskell 98 Report" is distributed under 82 | the following license: 83 | 84 | Copyright (c) 2002 Manuel M. T. Chakravarty 85 | 86 | The authors intend this Report to belong to the entire Haskell 87 | community, and so we grant permission to copy and distribute it for 88 | any purpose, provided that it is reproduced in its entirety, 89 | including this Notice. Modified versions of this Report may also be 90 | copied and distributed for any purpose, provided that the modified 91 | version is clearly presented as such, and that it does not claim to 92 | be a definition of the Haskell 98 Foreign Function Interface. 93 | 94 | ----------------------------------------------------------------------------- 95 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | dependent-map [![Build Status](https://github.com/obsidiansystems/dependent-map/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/obsidiansystems/dependent-map/actions/workflows/haskell-ci.yml) [![Hackage](https://img.shields.io/hackage/v/dependent-map.svg)](http://hackage.haskell.org/package/dependent-map) 2 | ============== 3 | 4 | This library defines a dependently-typed finite map type. It is derived from `Data.Map.Map` in the `containers` package, but rather than (conceptually) storing pairs indexed by the first component, it stores `DSum`s (from the `dependent-sum` package) indexed by tag. For example 5 | 6 | ```haskell 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | module Example where 13 | 14 | import Data.Constraint.Extras.TH (deriveArgDict) 15 | import Data.Dependent.Map (DMap, fromList, singleton, union, unionWithKey) 16 | import Data.Dependent.Sum ((==>)) 17 | import Data.Functor.Identity (Identity(..)) 18 | import Data.GADT.Compare.TH (deriveGCompare, deriveGEq) 19 | import Data.GADT.Show.TH (deriveGShow) 20 | 21 | data Tag a where 22 | StringKey :: Tag String 23 | IntKey :: Tag Int 24 | DoubleKey :: Tag Double 25 | deriveGEq ''Tag 26 | deriveGCompare ''Tag 27 | deriveGShow ''Tag 28 | deriveArgDict ''Tag 29 | 30 | x :: DMap Tag Identity 31 | x = fromList [DoubleKey ==> pi, StringKey ==> "hello there"] 32 | 33 | y :: DMap Tag Identity 34 | y = singleton IntKey (Identity 42) 35 | 36 | z :: DMap Tag Identity 37 | z = y `union` fromList [DoubleKey ==> -1.1415926535897931] 38 | 39 | addFoo :: Tag v -> Identity v -> Identity v -> Identity v 40 | addFoo IntKey (Identity x) (Identity y) = Identity $ x + y 41 | addFoo DoubleKey (Identity x) (Identity y) = Identity $ x + y 42 | addFoo _ x _ = x 43 | 44 | main :: IO () 45 | main = mapM_ print 46 | [ x, y, z 47 | , unionWithKey addFoo x z 48 | ] 49 | ``` 50 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain 5 | 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | allow-newer: constraints-extras:base 4 | allow-newer: constraints-extras:template-haskell 5 | -------------------------------------------------------------------------------- /dependent-map.cabal: -------------------------------------------------------------------------------- 1 | name: dependent-map 2 | version: 0.4.0.1 3 | stability: provisional 4 | 5 | cabal-version: >= 1.8 6 | build-type: Simple 7 | 8 | author: James Cook 9 | maintainer: Obsidian Systems, LLC 10 | license: OtherLicense 11 | license-file: LICENSE 12 | homepage: https://github.com/obsidiansystems/dependent-map 13 | 14 | category: Data, Dependent Types 15 | synopsis: Dependent finite maps (partial dependent products) 16 | description: Provides a type called @DMap@ which generalizes 17 | @Data.Map.Map@, allowing keys to specify the type 18 | of value that can be associated with them. 19 | 20 | extra-source-files: ChangeLog.md 21 | README.md 22 | 23 | tested-with: GHC == 8.4.4, 24 | GHC == 8.6.5, 25 | GHC == 8.8.4, 26 | GHC == 8.10.7, 27 | GHC == 9.0.2, 28 | GHC == 9.2.8, 29 | GHC == 9.4.8, 30 | GHC == 9.6.5, 31 | GHC == 9.8.2, 32 | GHC == 9.10.1 33 | 34 | source-repository head 35 | type: git 36 | location: https://github.com/obsidiansystems/dependent-map 37 | 38 | Library 39 | hs-source-dirs: src 40 | ghc-options: -fwarn-unused-imports -fwarn-unused-binds 41 | exposed-modules: Data.Dependent.Map, 42 | Data.Dependent.Map.Lens, 43 | Data.Dependent.Map.Internal 44 | other-modules: Data.Dependent.Map.PtrEquality 45 | build-depends: base >= 4.11 && < 5, 46 | containers >= 0.5.7.1 && <0.8, 47 | dependent-sum >= 0.6.1 && < 0.8, 48 | constraints-extras >= 0.2.3.0 && < 0.5 49 | -------------------------------------------------------------------------------- /src/Data/Dependent/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE Trustworthy #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | module Data.Dependent.Map 13 | ( DMap 14 | 15 | -- * Operators 16 | , (!), (\\) 17 | 18 | -- * Query 19 | , null 20 | , size 21 | , member 22 | , notMember 23 | , lookup 24 | , findWithDefault 25 | 26 | -- * Construction 27 | , empty 28 | , singleton 29 | 30 | -- ** Insertion 31 | , insert 32 | , insertWith 33 | , insertWith' 34 | , insertWithKey 35 | , insertWithKey' 36 | , insertLookupWithKey 37 | , insertLookupWithKey' 38 | 39 | -- ** Delete\/Update 40 | , delete 41 | , adjust 42 | , adjustWithKey 43 | , adjustWithKey' 44 | , update 45 | , updateWithKey 46 | , updateLookupWithKey 47 | , alter 48 | , alterF 49 | 50 | -- * Combine 51 | 52 | -- ** Union 53 | , union 54 | , unionWithKey 55 | , unions 56 | , unionsWithKey 57 | 58 | -- ** Difference 59 | , difference 60 | , differenceWithKey 61 | 62 | -- ** Intersection 63 | , intersection 64 | , intersectionWithKey 65 | 66 | -- * Traversal 67 | -- ** Map 68 | , map 69 | , ffor 70 | , mapWithKey 71 | , fforWithKey 72 | , traverseWithKey_ 73 | , forWithKey_ 74 | , traverseWithKey 75 | , forWithKey 76 | , mapAccumLWithKey 77 | , mapAccumRWithKey 78 | , mapKeysWith 79 | , mapKeysMonotonic 80 | 81 | -- ** Fold 82 | , foldWithKey 83 | , foldrWithKey 84 | , foldlWithKey 85 | -- , foldlWithKey' 86 | 87 | -- * Conversion 88 | , keys 89 | , assocs 90 | 91 | -- ** Lists 92 | , toList 93 | , fromList 94 | , fromListWithKey 95 | 96 | -- ** Ordered lists 97 | , toAscList 98 | , toDescList 99 | , fromAscList 100 | , fromAscListWithKey 101 | , fromDistinctAscList 102 | 103 | -- * Filter 104 | , filter 105 | , filterWithKey 106 | , partitionWithKey 107 | 108 | , mapMaybe 109 | , mapMaybeWithKey 110 | , mapEitherWithKey 111 | 112 | , split 113 | , splitLookup 114 | 115 | -- * Submap 116 | , isSubmapOf, isSubmapOfBy 117 | , isProperSubmapOf, isProperSubmapOfBy 118 | 119 | -- * Indexed 120 | , lookupIndex 121 | , findIndex 122 | , elemAt 123 | , updateAt 124 | , deleteAt 125 | 126 | -- * Min\/Max 127 | , findMin 128 | , findMax 129 | , lookupMin 130 | , lookupMax 131 | , deleteMin 132 | , deleteMax 133 | , deleteFindMin 134 | , deleteFindMax 135 | , updateMinWithKey 136 | , updateMaxWithKey 137 | , minViewWithKey 138 | , maxViewWithKey 139 | 140 | -- * Debugging 141 | , showTree 142 | , showTreeWith 143 | , valid 144 | ) where 145 | 146 | import Prelude hiding (null, lookup, map) 147 | import qualified Prelude 148 | import Data.Constraint.Extras (Has', has') 149 | import Data.Dependent.Sum (DSum((:=>))) 150 | import Data.GADT.Compare (GCompare, GEq, GOrdering(..), gcompare, geq) 151 | import Data.GADT.Show (GRead, GShow) 152 | import Data.Maybe (isJust) 153 | import Data.Some (Some, mkSome) 154 | import Data.Typeable ((:~:)(Refl)) 155 | import Text.Read (Lexeme(Ident), lexP, parens, prec, readListPrec, 156 | readListPrecDefault, readPrec) 157 | 158 | import Data.Dependent.Map.Internal 159 | import Data.Dependent.Map.PtrEquality (ptrEq) 160 | 161 | instance (GCompare k) => Monoid (DMap k f) where 162 | mempty = empty 163 | mconcat = unions 164 | 165 | instance (GCompare k) => Semigroup (DMap k f) where 166 | (<>) = union 167 | 168 | {-------------------------------------------------------------------- 169 | Operators 170 | --------------------------------------------------------------------} 171 | infixl 9 \\,! -- \\ at the end of the line means line continuation 172 | 173 | -- | /O(log n)/. Find the value at a key. 174 | -- Calls 'error' when the element can not be found. 175 | -- 176 | -- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map 177 | -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a' 178 | 179 | (!) :: GCompare k => DMap k f -> k v -> f v 180 | (!) m k = find k m 181 | 182 | -- | Same as 'difference'. 183 | (\\) :: GCompare k => DMap k f -> DMap k f -> DMap k f 184 | m1 \\ m2 = difference m1 m2 185 | 186 | -- #if __GLASGOW_HASKELL__ 187 | -- 188 | -- {-------------------------------------------------------------------- 189 | -- A Data instance 190 | -- --------------------------------------------------------------------} 191 | -- 192 | -- -- This instance preserves data abstraction at the cost of inefficiency. 193 | -- -- We omit reflection services for the sake of data abstraction. 194 | -- 195 | -- instance (Data k, Data a, GCompare k) => Data (DMap k) where 196 | -- gfoldl f z m = z fromList `f` toList m 197 | -- toConstr _ = error "toConstr" 198 | -- gunfold _ _ = error "gunfold" 199 | -- dataTypeOf _ = mkNoRepType "Data.Map.Map" 200 | -- dataCast2 f = gcast2 f 201 | -- 202 | -- #endif 203 | 204 | {-------------------------------------------------------------------- 205 | Query 206 | --------------------------------------------------------------------} 207 | 208 | -- | /O(log n)/. Is the key a member of the map? See also 'notMember'. 209 | member :: GCompare k => k a -> DMap k f -> Bool 210 | member k = isJust . lookup k 211 | 212 | -- | /O(log n)/. Is the key not a member of the map? See also 'member'. 213 | notMember :: GCompare k => k v -> DMap k f -> Bool 214 | notMember k m = not (member k m) 215 | 216 | -- | /O(log n)/. Find the value at a key. 217 | -- Calls 'error' when the element can not be found. 218 | -- Consider using 'lookup' when elements may not be present. 219 | find :: GCompare k => k v -> DMap k f -> f v 220 | find k m = case lookup k m of 221 | Nothing -> error "DMap.find: element not in the map" 222 | Just v -> v 223 | 224 | -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns 225 | -- the value at key @k@ or returns default value @def@ 226 | -- when the key is not in the map. 227 | findWithDefault :: GCompare k => f v -> k v -> DMap k f -> f v 228 | findWithDefault def k m = case lookup k m of 229 | Nothing -> def 230 | Just v -> v 231 | 232 | {-------------------------------------------------------------------- 233 | Insertion 234 | --------------------------------------------------------------------} 235 | 236 | -- | /O(log n)/. Insert a new key and value in the map. 237 | -- If the key is already present in the map, the associated value is 238 | -- replaced with the supplied value. 'insert' is equivalent to 239 | -- @'insertWith' 'const'@. 240 | insert :: forall k f v. GCompare k => k v -> f v -> DMap k f -> DMap k f 241 | insert kx x = kx `seq` go 242 | where 243 | go :: DMap k f -> DMap k f 244 | go Tip = singleton kx x 245 | go t@(Bin sz ky y l r) = case gcompare kx ky of 246 | GLT -> let !l' = go l 247 | in if l' `ptrEq` l 248 | then t 249 | else balance ky y l' r 250 | GGT -> let !r' = go r 251 | in if r' `ptrEq` r 252 | then t 253 | else balance ky y l r' 254 | GEQ 255 | | kx `ptrEq` ky && x `ptrEq` y -> t 256 | | otherwise -> Bin sz kx x l r 257 | 258 | -- | /O(log n)/. Insert a new key and value in the map if the key 259 | -- is not already present. If the key is already present, @insertR@ 260 | -- does nothing. 261 | insertR :: forall k f v. GCompare k => k v -> f v -> DMap k f -> DMap k f 262 | insertR kx x = kx `seq` go 263 | where 264 | go :: DMap k f -> DMap k f 265 | go Tip = singleton kx x 266 | go t@(Bin sz ky y l r) = case gcompare kx ky of 267 | GLT -> let !l' = go l 268 | in if l' `ptrEq` l 269 | then t 270 | else balance ky y l' r 271 | GGT -> let !r' = go r 272 | in if r' `ptrEq` r 273 | then t 274 | else balance ky y l r' 275 | GEQ -> t 276 | 277 | -- | /O(log n)/. Insert with a function, combining new value and old value. 278 | -- @'insertWith' f key value mp@ 279 | -- will insert the entry @key :=> value@ into @mp@ if key does 280 | -- not exist in the map. If the key does exist, the function will 281 | -- insert the entry @key :=> f new_value old_value@. 282 | insertWith :: GCompare k => (f v -> f v -> f v) -> k v -> f v -> DMap k f -> DMap k f 283 | insertWith f = insertWithKey (\_ x' y' -> f x' y') 284 | 285 | -- | Same as 'insertWith', but the combining function is applied strictly. 286 | -- This is often the most desirable behavior. 287 | insertWith' :: GCompare k => (f v -> f v -> f v) -> k v -> f v -> DMap k f -> DMap k f 288 | insertWith' f = insertWithKey' (\_ x' y' -> f x' y') 289 | 290 | -- | /O(log n)/. Insert with a function, combining key, new value and old value. 291 | -- @'insertWithKey' f key value mp@ 292 | -- will insert the entry @key :=> value@ into @mp@ if key does 293 | -- not exist in the map. If the key does exist, the function will 294 | -- insert the entry @key :=> f key new_value old_value@. 295 | -- Note that the key passed to f is the same key passed to 'insertWithKey'. 296 | insertWithKey :: forall k f v. GCompare k => (k v -> f v -> f v -> f v) -> k v -> f v -> DMap k f -> DMap k f 297 | insertWithKey f kx x = kx `seq` go 298 | where 299 | go :: DMap k f -> DMap k f 300 | go Tip = singleton kx x 301 | go (Bin sy ky y l r) = 302 | case gcompare kx ky of 303 | GLT -> balance ky y (go l) r 304 | GGT -> balance ky y l (go r) 305 | GEQ -> Bin sy kx (f kx x y) l r 306 | 307 | -- | Same as 'insertWithKey', but the combining function is applied strictly. 308 | insertWithKey' :: forall k f v. GCompare k => (k v -> f v -> f v -> f v) -> k v -> f v -> DMap k f -> DMap k f 309 | insertWithKey' f kx x = kx `seq` go 310 | where 311 | go :: DMap k f -> DMap k f 312 | go Tip = singleton kx $! x 313 | go (Bin sy ky y l r) = 314 | case gcompare kx ky of 315 | GLT -> balance ky y (go l) r 316 | GGT -> balance ky y l (go r) 317 | GEQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r) 318 | 319 | -- | /O(log n)/. Combines insert operation with old value retrieval. 320 | -- The expression (@'insertLookupWithKey' f k x map@) 321 | -- is a pair where the first element is equal to (@'lookup' k map@) 322 | -- and the second element equal to (@'insertWithKey' f k x map@). 323 | insertLookupWithKey :: forall k f v. GCompare k => (k v -> f v -> f v -> f v) -> k v -> f v -> DMap k f 324 | -> (Maybe (f v), DMap k f) 325 | insertLookupWithKey f kx x = kx `seq` go 326 | where 327 | go :: DMap k f -> (Maybe (f v), DMap k f) 328 | go Tip = (Nothing, singleton kx x) 329 | go (Bin sy ky y l r) = 330 | case gcompare kx ky of 331 | GLT -> let (found, l') = go l 332 | in (found, balance ky y l' r) 333 | GGT -> let (found, r') = go r 334 | in (found, balance ky y l r') 335 | GEQ -> (Just y, Bin sy kx (f kx x y) l r) 336 | 337 | -- | /O(log n)/. A strict version of 'insertLookupWithKey'. 338 | insertLookupWithKey' :: forall k f v. GCompare k => (k v -> f v -> f v -> f v) -> k v -> f v -> DMap k f 339 | -> (Maybe (f v), DMap k f) 340 | insertLookupWithKey' f kx x = kx `seq` go 341 | where 342 | go :: DMap k f -> (Maybe (f v), DMap k f) 343 | go Tip = x `seq` (Nothing, singleton kx x) 344 | go (Bin sy ky y l r) = 345 | case gcompare kx ky of 346 | GLT -> let (found, l') = go l 347 | in (found, balance ky y l' r) 348 | GGT -> let (found, r') = go r 349 | in (found, balance ky y l r') 350 | GEQ -> let x' = f kx x y in x' `seq` (Just y, Bin sy kx x' l r) 351 | 352 | {-------------------------------------------------------------------- 353 | Deletion 354 | [delete] is the inlined version of [deleteWith (\k x -> Nothing)] 355 | --------------------------------------------------------------------} 356 | 357 | -- | /O(log n)/. Delete a key and its value from the map. When the key is not 358 | -- a member of the map, the original map is returned. 359 | delete :: forall k f v. GCompare k => k v -> DMap k f -> DMap k f 360 | delete k = k `seq` go 361 | where 362 | go :: DMap k f -> DMap k f 363 | go Tip = Tip 364 | go (Bin _ kx x l r) = 365 | case gcompare k kx of 366 | GLT -> balance kx x (go l) r 367 | GGT -> balance kx x l (go r) 368 | GEQ -> glue l r 369 | 370 | -- | /O(log n)/. Update a value at a specific key with the result of the provided function. 371 | -- When the key is not 372 | -- a member of the map, the original map is returned. 373 | adjust :: GCompare k => (f v -> f v) -> k v -> DMap k f -> DMap k f 374 | adjust f = adjustWithKey (\_ x -> f x) 375 | 376 | -- | /O(log n)/. Adjust a value at a specific key. When the key is not 377 | -- a member of the map, the original map is returned. 378 | adjustWithKey :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f 379 | adjustWithKey f0 !k0 = go f0 k0 380 | where 381 | go :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f 382 | go _f _k Tip = Tip 383 | go f k (Bin sx kx x l r) = 384 | case gcompare k kx of 385 | GLT -> Bin sx kx x (go f k l) r 386 | GGT -> Bin sx kx x l (go f k r) 387 | GEQ -> Bin sx kx (f kx x) l r 388 | 389 | -- | /O(log n)/. A strict version of 'adjustWithKey'. 390 | adjustWithKey' :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f 391 | adjustWithKey' f0 !k0 = go f0 k0 392 | where 393 | go :: GCompare k => (k v -> f v -> f v) -> k v -> DMap k f -> DMap k f 394 | go _f _k Tip = Tip 395 | go f k (Bin sx kx x l r) = 396 | case gcompare k kx of 397 | GLT -> Bin sx kx x (go f k l) r 398 | GGT -> Bin sx kx x l (go f k r) 399 | GEQ -> let !x' = f kx x in Bin sx kx x' l r 400 | 401 | -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ 402 | -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is 403 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. 404 | update :: GCompare k => (f v -> Maybe (f v)) -> k v -> DMap k f -> DMap k f 405 | update f = updateWithKey (\_ x -> f x) 406 | 407 | -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the 408 | -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', 409 | -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound 410 | -- to the new value @y@. 411 | updateWithKey :: forall k f v. GCompare k => (k v -> f v -> Maybe (f v)) -> k v -> DMap k f -> DMap k f 412 | updateWithKey f k = k `seq` go 413 | where 414 | go :: DMap k f -> DMap k f 415 | go Tip = Tip 416 | go (Bin sx kx x l r) = 417 | case gcompare k kx of 418 | GLT -> balance kx x (go l) r 419 | GGT -> balance kx x l (go r) 420 | GEQ -> case f kx x of 421 | Just x' -> Bin sx kx x' l r 422 | Nothing -> glue l r 423 | 424 | -- | /O(log n)/. Lookup and update. See also 'updateWithKey'. 425 | -- The function returns changed value, if it is updated. 426 | -- Returns the original key value if the map entry is deleted. 427 | updateLookupWithKey :: forall k f v. GCompare k => (k v -> f v -> Maybe (f v)) -> k v -> DMap k f -> (Maybe (f v), DMap k f) 428 | updateLookupWithKey f k = k `seq` go 429 | where 430 | go :: DMap k f -> (Maybe (f v), DMap k f) 431 | go Tip = (Nothing,Tip) 432 | go (Bin sx kx x l r) = 433 | case gcompare k kx of 434 | GLT -> let (found,l') = go l in (found,balance kx x l' r) 435 | GGT -> let (found,r') = go r in (found,balance kx x l r') 436 | GEQ -> case f kx x of 437 | Just x' -> (Just x',Bin sx kx x' l r) 438 | Nothing -> (Just x,glue l r) 439 | 440 | -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. 441 | -- 'alter' can be used to insert, delete, or update a value in a 'Map'. 442 | -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. 443 | alter :: forall k f v. GCompare k => (Maybe (f v) -> Maybe (f v)) -> k v -> DMap k f -> DMap k f 444 | alter f k = k `seq` go 445 | where 446 | go :: DMap k f -> DMap k f 447 | go Tip = case f Nothing of 448 | Nothing -> Tip 449 | Just x -> singleton k x 450 | 451 | go (Bin sx kx x l r) = case gcompare k kx of 452 | GLT -> balance kx x (go l) r 453 | GGT -> balance kx x l (go r) 454 | GEQ -> case f (Just x) of 455 | Just x' -> Bin sx kx x' l r 456 | Nothing -> glue l r 457 | 458 | -- | Works the same as 'alter' except the new value is returned in some 'Functor' @f@. 459 | -- In short : @(\v' -> alter (const v') k dm) <$> f (lookup k dm)@ 460 | alterF :: forall k f v g. (GCompare k, Functor f) => k v -> (Maybe (g v) -> f (Maybe (g v))) -> DMap k g -> f (DMap k g) 461 | alterF k f = go 462 | where 463 | go :: DMap k g -> f (DMap k g) 464 | go Tip = maybe Tip (singleton k) <$> f Nothing 465 | 466 | go (Bin sx kx x l r) = case gcompare k kx of 467 | GLT -> (\l' -> balance kx x l' r) <$> go l 468 | GGT -> (\r' -> balance kx x l r') <$> go r 469 | GEQ -> maybe (glue l r) (\x' -> Bin sx kx x' l r) <$> f (Just x) 470 | 471 | {-------------------------------------------------------------------- 472 | Indexing 473 | --------------------------------------------------------------------} 474 | 475 | -- | /O(log n)/. Return the /index/ of a key. The index is a number from 476 | -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when 477 | -- the key is not a 'member' of the map. 478 | findIndex :: GCompare k => k v -> DMap k f -> Int 479 | findIndex k t 480 | = case lookupIndex k t of 481 | Nothing -> error "Map.findIndex: element is not in the map" 482 | Just idx -> idx 483 | 484 | -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from 485 | -- /0/ up to, but not including, the 'size' of the map. 486 | lookupIndex :: forall k f v. GCompare k => k v -> DMap k f -> Maybe Int 487 | lookupIndex k = k `seq` go 0 488 | where 489 | go :: Int -> DMap k f -> Maybe Int 490 | go !idx Tip = idx `seq` Nothing 491 | go !idx (Bin _ kx _ l r) 492 | = case gcompare k kx of 493 | GLT -> go idx l 494 | GGT -> go (idx + size l + 1) r 495 | GEQ -> Just (idx + size l) 496 | 497 | -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an 498 | -- invalid index is used. 499 | elemAt :: Int -> DMap k f -> DSum k f 500 | elemAt _ Tip = error "Map.elemAt: index out of range" 501 | elemAt i (Bin _ kx x l r) 502 | = case compare i sizeL of 503 | LT -> elemAt i l 504 | GT -> elemAt (i-sizeL-1) r 505 | EQ -> kx :=> x 506 | where 507 | sizeL = size l 508 | 509 | -- | /O(log n)/. Update the element at /index/. Does nothing when an 510 | -- invalid index is used. 511 | updateAt :: (forall v. k v -> f v -> Maybe (f v)) -> Int -> DMap k f -> DMap k f 512 | updateAt f i0 t = i0 `seq` go i0 t 513 | where 514 | go _ Tip = Tip 515 | go i (Bin sx kx x l r) = case compare i sizeL of 516 | LT -> balance kx x (go i l) r 517 | GT -> balance kx x l (go (i-sizeL-1) r) 518 | EQ -> case f kx x of 519 | Just x' -> Bin sx kx x' l r 520 | Nothing -> glue l r 521 | where 522 | sizeL = size l 523 | 524 | -- | /O(log n)/. Delete the element at /index/. 525 | -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@). 526 | deleteAt :: Int -> DMap k f -> DMap k f 527 | deleteAt i m 528 | = updateAt (\_ _ -> Nothing) i m 529 | 530 | 531 | {-------------------------------------------------------------------- 532 | Minimal, Maximal 533 | --------------------------------------------------------------------} 534 | 535 | -- | /O(log n)/. The minimal key of the map. Calls 'error' is the map is empty. 536 | findMin :: DMap k f -> DSum k f 537 | findMin m = case lookupMin m of 538 | Just x -> x 539 | Nothing -> error "Map.findMin: empty map has no minimal element" 540 | 541 | lookupMin :: DMap k f -> Maybe (DSum k f) 542 | lookupMin m = case m of 543 | Tip -> Nothing 544 | Bin _ kx x l _ -> Just $! go kx x l 545 | where 546 | go :: k v -> f v -> DMap k f -> DSum k f 547 | go kx x Tip = kx :=> x 548 | go _ _ (Bin _ kx x l _) = go kx x l 549 | 550 | -- | /O(log n)/. The maximal key of the map. Calls 'error' is the map is empty. 551 | findMax :: DMap k f -> DSum k f 552 | findMax m = case lookupMax m of 553 | Just x -> x 554 | Nothing -> error "Map.findMax: empty map has no maximal element" 555 | 556 | lookupMax :: DMap k f -> Maybe (DSum k f) 557 | lookupMax m = case m of 558 | Tip -> Nothing 559 | Bin _ kx x _ r -> Just $! go kx x r 560 | where 561 | go :: k v -> f v -> DMap k f -> DSum k f 562 | go kx x Tip = kx :=> x 563 | go _ _ (Bin _ kx x _ r) = go kx x r 564 | 565 | -- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty. 566 | deleteMin :: DMap k f -> DMap k f 567 | deleteMin (Bin _ _ _ Tip r) = r 568 | deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r 569 | deleteMin Tip = Tip 570 | 571 | -- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty. 572 | deleteMax :: DMap k f -> DMap k f 573 | deleteMax (Bin _ _ _ l Tip) = l 574 | deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r) 575 | deleteMax Tip = Tip 576 | 577 | -- | /O(log n)/. Update the value at the minimal key. 578 | updateMinWithKey :: (forall v. k v -> f v -> Maybe (f v)) -> DMap k f -> DMap k f 579 | updateMinWithKey f = go 580 | where 581 | go (Bin sx kx x Tip r) = case f kx x of 582 | Nothing -> r 583 | Just x' -> Bin sx kx x' Tip r 584 | go (Bin _ kx x l r) = balance kx x (go l) r 585 | go Tip = Tip 586 | 587 | -- | /O(log n)/. Update the value at the maximal key. 588 | updateMaxWithKey :: (forall v. k v -> f v -> Maybe (f v)) -> DMap k f -> DMap k f 589 | updateMaxWithKey f = go 590 | where 591 | go (Bin sx kx x l Tip) = case f kx x of 592 | Nothing -> l 593 | Just x' -> Bin sx kx x' l Tip 594 | go (Bin _ kx x l r) = balance kx x l (go r) 595 | go Tip = Tip 596 | 597 | {-------------------------------------------------------------------- 598 | Union. 599 | --------------------------------------------------------------------} 600 | 601 | -- | The union of a list of maps: 602 | -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). 603 | unions :: GCompare k => [DMap k f] -> DMap k f 604 | unions ts 605 | = foldlStrict union empty ts 606 | 607 | -- | The union of a list of maps, with a combining operation: 608 | -- (@'unionsWithKey' f == 'Prelude.foldl' ('unionWithKey' f) 'empty'@). 609 | unionsWithKey :: GCompare k => (forall v. k v -> f v -> f v -> f v) -> [DMap k f] -> DMap k f 610 | unionsWithKey f ts 611 | = foldlStrict (unionWithKey f) empty ts 612 | 613 | -- | /O(m*log(n\/m + 1)), m <= n/. 614 | -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. 615 | -- It prefers @t1@ when duplicate keys are encountered, 616 | -- i.e. (@'union' == 'unionWith' 'const'@). 617 | union :: GCompare k => DMap k f -> DMap k f -> DMap k f 618 | union t1 Tip = t1 619 | union t1 (Bin _ kx x Tip Tip) = insertR kx x t1 620 | union Tip t2 = t2 621 | union (Bin _ kx x Tip Tip) t2 = insert kx x t2 622 | union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of 623 | (l2, r2) 624 | | l1 `ptrEq` l1l2 && r1 `ptrEq` r1r2 -> t1 625 | | otherwise -> combine k1 x1 l1l2 r1r2 626 | where !l1l2 = l1 `union` l2 627 | !r1r2 = r1 `union` r2 628 | 629 | {-------------------------------------------------------------------- 630 | Union with a combining function 631 | --------------------------------------------------------------------} 632 | 633 | -- | /O(n+m)/. 634 | -- Union with a combining function. 635 | unionWithKey :: GCompare k => (forall v. k v -> f v -> f v -> f v) -> DMap k f -> DMap k f -> DMap k f 636 | unionWithKey _ t1 Tip = t1 637 | unionWithKey _ Tip t2 = t2 638 | unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of 639 | (l2, mx2, r2) -> case mx2 of 640 | Nothing -> combine k1 x1 l1l2 r1r2 641 | Just x2 -> combine k1 (f k1 x1 x2) l1l2 r1r2 642 | where !l1l2 = unionWithKey f l1 l2 643 | !r1r2 = unionWithKey f r1 r2 644 | 645 | {-------------------------------------------------------------------- 646 | Difference 647 | --------------------------------------------------------------------} 648 | 649 | -- | /O(m * log (n\/m + 1)), m <= n/. Difference of two maps. 650 | -- Return elements of the first map not existing in the second map. 651 | difference :: GCompare k => DMap k f -> DMap k g -> DMap k f 652 | difference Tip _ = Tip 653 | difference t1 Tip = t1 654 | difference t1 (Bin _ k2 _x2 l2 r2) = case split k2 t1 of 655 | (l1, r1) 656 | | size t1 == size l1l2 + size r1r2 -> t1 657 | | otherwise -> merge l1l2 r1r2 658 | where 659 | !l1l2 = l1 `difference` l2 660 | !r1r2 = r1 `difference` r2 661 | 662 | -- | /O(n+m)/. Difference with a combining function. When two equal keys are 663 | -- encountered, the combining function is applied to the key and both values. 664 | -- If it returns 'Nothing', the element is discarded (proper set difference). If 665 | -- it returns (@'Just' y@), the element is updated with a new value @y@. 666 | differenceWithKey :: GCompare k => (forall v. k v -> f v -> g v -> Maybe (f v)) -> DMap k f -> DMap k g -> DMap k f 667 | differenceWithKey _ Tip _ = Tip 668 | differenceWithKey _ t1 Tip = t1 669 | differenceWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of 670 | (l2, mx2, r2) -> case mx2 of 671 | Nothing -> combine k1 x1 l1l2 r1r2 672 | Just x2 -> case f k1 x1 x2 of 673 | Nothing -> merge l1l2 r1r2 674 | Just x1x2 -> combine k1 x1x2 l1l2 r1r2 675 | where !l1l2 = differenceWithKey f l1 l2 676 | !r1r2 = differenceWithKey f r1 r2 677 | 678 | {-------------------------------------------------------------------- 679 | Intersection 680 | --------------------------------------------------------------------} 681 | 682 | -- | /O(m * log (n\/m + 1), m <= n/. Intersection of two maps. 683 | -- Return data in the first map for the keys existing in both maps. 684 | -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). 685 | intersection :: GCompare k => DMap k f -> DMap k f -> DMap k f 686 | intersection Tip _ = Tip 687 | intersection _ Tip = Tip 688 | intersection t1@(Bin s1 k1 x1 l1 r1) t2 = 689 | let !(l2, found, r2) = splitMember k1 t2 690 | !l1l2 = intersection l1 l2 691 | !r1r2 = intersection r1 r2 692 | in if found 693 | then if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 694 | then t1 695 | else combine k1 x1 l1l2 r1r2 696 | else merge l1l2 r1r2 697 | 698 | -- | /O(m * log (n\/m + 1), m <= n/. Intersection with a combining function. 699 | intersectionWithKey :: GCompare k => (forall v. k v -> f v -> g v -> h v) -> DMap k f -> DMap k g -> DMap k h 700 | intersectionWithKey _ Tip _ = Tip 701 | intersectionWithKey _ _ Tip = Tip 702 | intersectionWithKey f (Bin s1 k1 x1 l1 r1) t2 = 703 | let !(l2, found, r2) = splitLookup k1 t2 704 | !l1l2 = intersectionWithKey f l1 l2 705 | !r1r2 = intersectionWithKey f r1 r2 706 | in case found of 707 | Nothing -> merge l1l2 r1r2 708 | Just x2 -> combine k1 (f k1 x1 x2) l1l2 r1r2 709 | 710 | {-------------------------------------------------------------------- 711 | Submap 712 | --------------------------------------------------------------------} 713 | -- | /O(n+m)/. 714 | -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' 'eqTagged')@). 715 | -- 716 | isSubmapOf 717 | :: forall k f 718 | . (GCompare k, Has' Eq k f) 719 | => DMap k f -> DMap k f -> Bool 720 | isSubmapOf m1 m2 = isSubmapOfBy (\k _ x0 x1 -> has' @Eq @f k (x0 == x1)) m1 m2 721 | 722 | {- | /O(n+m)/. 723 | The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if 724 | all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when 725 | applied to their respective keys and values. 726 | -} 727 | isSubmapOfBy :: GCompare k => (forall v. k v -> k v -> f v -> g v -> Bool) -> DMap k f -> DMap k g -> Bool 728 | isSubmapOfBy f t1 t2 729 | = (size t1 <= size t2) && (submap' f t1 t2) 730 | 731 | submap' :: GCompare k => (forall v. k v -> k v -> f v -> g v -> Bool) -> DMap k f -> DMap k g -> Bool 732 | submap' _ Tip _ = True 733 | submap' _ _ Tip = False 734 | submap' f (Bin _ kx x l r) t 735 | = case found of 736 | Nothing -> False 737 | Just (ky, y) -> f kx ky x y && submap' f l lt && submap' f r gt 738 | where 739 | (lt,found,gt) = splitLookupWithKey kx t 740 | 741 | -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). 742 | -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' 'eqTagged'@). 743 | isProperSubmapOf 744 | :: forall k f 745 | . (GCompare k, Has' Eq k f) 746 | => DMap k f -> DMap k f -> Bool 747 | isProperSubmapOf m1 m2 748 | = isProperSubmapOfBy (\k _ x0 x1 -> has' @Eq @f k (x0 == x1)) m1 m2 749 | 750 | {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). 751 | The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when 752 | @m1@ and @m2@ are not equal, 753 | all keys in @m1@ are in @m2@, and when @f@ returns 'True' when 754 | applied to their respective keys and values. 755 | -} 756 | isProperSubmapOfBy :: GCompare k => (forall v. k v -> k v -> f v -> g v -> Bool) -> DMap k f -> DMap k g -> Bool 757 | isProperSubmapOfBy f t1 t2 758 | = (size t1 < size t2) && (submap' f t1 t2) 759 | 760 | {-------------------------------------------------------------------- 761 | Filter and partition 762 | --------------------------------------------------------------------} 763 | 764 | -- | /O(n)/. Filter all keys\/values that satisfy the predicate. 765 | filterWithKey :: GCompare k => (forall v. k v -> f v -> Bool) -> DMap k f -> DMap k f 766 | filterWithKey p = go 767 | where 768 | go Tip = Tip 769 | go t@(Bin _ kx x l r) 770 | | p kx x = if l' `ptrEq` l && r' `ptrEq` r 771 | then t 772 | else combine kx x l' r' 773 | | otherwise = merge l' r' 774 | where !l' = go l 775 | !r' = go r 776 | 777 | -- | /O(n)/. Partition the map according to a predicate. The first 778 | -- map contains all elements that satisfy the predicate, the second all 779 | -- elements that fail the predicate. See also 'split'. 780 | partitionWithKey :: GCompare k => (forall v. k v -> f v -> Bool) -> DMap k f -> (DMap k f, DMap k f) 781 | partitionWithKey p0 m0 = toPair (go p0 m0) 782 | where 783 | go :: GCompare k => (forall v. k v -> f v -> Bool) -> DMap k f -> (DMap k f :*: DMap k f) 784 | go _ Tip = (Tip :*: Tip) 785 | go p (Bin _ kx x l r) 786 | | p kx x = (combine kx x l1 r1 :*: merge l2 r2) 787 | | otherwise = (merge l1 r1 :*: combine kx x l2 r2) 788 | where 789 | (l1 :*: l2) = go p l 790 | (r1 :*: r2) = go p r 791 | 792 | -- | /O(n)/. Map values and collect the 'Just' results. 793 | mapMaybe :: GCompare k => (forall v. f v -> Maybe (g v)) -> DMap k f -> DMap k g 794 | mapMaybe f = mapMaybeWithKey (const f) 795 | 796 | -- | /O(n)/. Map keys\/values and collect the 'Just' results. 797 | mapMaybeWithKey :: GCompare k => (forall v. k v -> f v -> Maybe (g v)) -> DMap k f -> DMap k g 798 | mapMaybeWithKey f = go 799 | where 800 | go Tip = Tip 801 | go (Bin _ kx x l r) = case f kx x of 802 | Just y -> combine kx y (go l) (go r) 803 | Nothing -> merge (go l) (go r) 804 | 805 | -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. 806 | mapEitherWithKey :: GCompare k => 807 | (forall v. k v -> f v -> Either (g v) (h v)) -> DMap k f -> (DMap k g, DMap k h) 808 | mapEitherWithKey f0 = toPair . go f0 809 | where 810 | go :: GCompare k 811 | => (forall v. k v -> f v -> Either (g v) (h v)) 812 | -> DMap k f -> (DMap k g :*: DMap k h) 813 | go _ Tip = (Tip :*: Tip) 814 | go f (Bin _ kx x l r) = case f kx x of 815 | Left y -> (combine kx y l1 r1 :*: merge l2 r2) 816 | Right z -> (merge l1 r1 :*: combine kx z l2 r2) 817 | where 818 | (l1,l2) = mapEitherWithKey f l 819 | (r1,r2) = mapEitherWithKey f r 820 | 821 | {-------------------------------------------------------------------- 822 | Mapping 823 | --------------------------------------------------------------------} 824 | 825 | -- | /O(n)/. Map a function over all values in the map. 826 | map :: (forall v. f v -> g v) -> DMap k f -> DMap k g 827 | map f = go 828 | where 829 | go Tip = Tip 830 | go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r) 831 | 832 | -- | /O(n)/. 833 | -- @'ffor' == 'flip' 'map'@ except we cannot actually use 834 | -- 'flip' because of the lack of impredicative types. 835 | ffor :: DMap k f -> (forall v. f v -> g v) -> DMap k g 836 | ffor m f = map f m 837 | 838 | -- | /O(n)/. Map a function over all values in the map. 839 | mapWithKey :: (forall v. k v -> f v -> g v) -> DMap k f -> DMap k g 840 | mapWithKey f = go 841 | where 842 | go Tip = Tip 843 | go (Bin sx kx x l r) = Bin sx kx (f kx x) (go l) (go r) 844 | 845 | -- | /O(n)/. 846 | -- @'fforWithKey' == 'flip' 'mapWithKey'@ except we cannot actually use 847 | -- 'flip' because of the lack of impredicative types. 848 | fforWithKey :: DMap k f -> (forall v. k v -> f v -> g v) -> DMap k g 849 | fforWithKey m f = mapWithKey f m 850 | 851 | -- | /O(n)/. 852 | -- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ 853 | -- That is, behaves exactly like a regular 'traverse' except that the traversing 854 | -- function also has access to the key associated with a value. 855 | traverseWithKey_ :: Applicative t => (forall v. k v -> f v -> t ()) -> DMap k f -> t () 856 | traverseWithKey_ f = go 857 | where 858 | go Tip = pure () 859 | go (Bin 1 k v _ _) = f k v 860 | go (Bin s k v l r) = go l *> f k v *> go r 861 | 862 | -- | /O(n)/. 863 | -- @'forWithKey' == 'flip' 'traverseWithKey'@ except we cannot actually use 864 | -- 'flip' because of the lack of impredicative types. 865 | forWithKey_ :: Applicative t => DMap k f -> (forall v. k v -> f v -> t ()) -> t () 866 | forWithKey_ m f = traverseWithKey_ f m 867 | 868 | -- | /O(n)/. 869 | -- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ 870 | -- That is, behaves exactly like a regular 'traverse' except that the traversing 871 | -- function also has access to the key associated with a value. 872 | traverseWithKey :: Applicative t => (forall v. k v -> f v -> t (g v)) -> DMap k f -> t (DMap k g) 873 | traverseWithKey f = go 874 | where 875 | go Tip = pure Tip 876 | go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v 877 | go (Bin s k v l r) = flip (Bin s k) <$> go l <*> f k v <*> go r 878 | 879 | -- | /O(n)/. 880 | -- @'forWithKey' == 'flip' 'traverseWithKey'@ except we cannot actually use 881 | -- 'flip' because of the lack of impredicative types. 882 | forWithKey :: Applicative t => DMap k f -> (forall v. k v -> f v -> t (g v)) -> t (DMap k g) 883 | forWithKey m f = traverseWithKey f m 884 | 885 | -- | /O(n)/. The function 'mapAccumLWithKey' threads an accumulating 886 | -- argument through the map in ascending order of keys. 887 | mapAccumLWithKey :: (forall v. a -> k v -> f v -> (a, g v)) -> a -> DMap k f -> (a, DMap k g) 888 | mapAccumLWithKey f = go 889 | where 890 | go a Tip = (a,Tip) 891 | go a (Bin sx kx x l r) = 892 | let (a1,l') = go a l 893 | (a2,x') = f a1 kx x 894 | (a3,r') = go a2 r 895 | in (a3,Bin sx kx x' l' r') 896 | 897 | -- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating 898 | -- argument through the map in descending order of keys. 899 | mapAccumRWithKey :: (forall v. a -> k v -> f v -> (a, g v)) -> a -> DMap k f -> (a, DMap k g) 900 | mapAccumRWithKey f = go 901 | where 902 | go a Tip = (a,Tip) 903 | go a (Bin sx kx x l r) = 904 | let (a1,r') = go a r 905 | (a2,x') = f a1 kx x 906 | (a3,l') = go a2 l 907 | in (a3,Bin sx kx x' l' r') 908 | 909 | -- | /O(n*log n)/. 910 | -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. 911 | -- 912 | -- The size of the result may be smaller if @f@ maps two or more distinct 913 | -- keys to the same new key. In this case the associated values will be 914 | -- combined using @c@. 915 | mapKeysWith :: GCompare k2 => (forall v. k2 v -> f v -> f v -> f v) -> (forall v. k1 v -> k2 v) -> DMap k1 f -> DMap k2 f 916 | mapKeysWith c f = fromListWithKey c . Prelude.map fFirst . toList 917 | where fFirst (x :=> y) = (f x :=> y) 918 | 919 | 920 | -- | /O(n)/. 921 | -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ 922 | -- is strictly monotonic. 923 | -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. 924 | -- /The precondition is not checked./ 925 | -- Semi-formally, we have: 926 | -- 927 | -- > and [x < y ==> f x < f y | x <- ls, y <- ls] 928 | -- > ==> mapKeysMonotonic f s == mapKeys f s 929 | -- > where ls = keys s 930 | -- 931 | -- This means that @f@ maps distinct original keys to distinct resulting keys. 932 | -- This function has better performance than 'mapKeys'. 933 | mapKeysMonotonic :: (forall v. k1 v -> k2 v) -> DMap k1 f -> DMap k2 f 934 | mapKeysMonotonic _ Tip = Tip 935 | mapKeysMonotonic f (Bin sz k x l r) = 936 | Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r) 937 | 938 | {-------------------------------------------------------------------- 939 | Folds 940 | --------------------------------------------------------------------} 941 | 942 | -- | /O(n)/. Fold the keys and values in the map, such that 943 | -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. 944 | -- 945 | -- This is identical to 'foldrWithKey', and you should use that one instead of 946 | -- this one. This name is kept for backward compatibility. 947 | foldWithKey :: (forall v. k v -> f v -> b -> b) -> b -> DMap k f -> b 948 | foldWithKey = foldrWithKey 949 | {-# DEPRECATED foldWithKey "Use foldrWithKey instead" #-} 950 | 951 | -- | /O(n)/. Post-order fold. The function will be applied from the lowest 952 | -- value to the highest. 953 | foldrWithKey :: (forall v. k v -> f v -> b -> b) -> b -> DMap k f -> b 954 | foldrWithKey f = go 955 | where 956 | go z Tip = z 957 | go z (Bin _ kx x l r) = go (f kx x (go z r)) l 958 | 959 | -- | /O(n)/. Pre-order fold. The function will be applied from the highest 960 | -- value to the lowest. 961 | foldlWithKey :: (forall v. b -> k v -> f v -> b) -> b -> DMap k f -> b 962 | foldlWithKey f = go 963 | where 964 | go z Tip = z 965 | go z (Bin _ kx x l r) = go (f (go z l) kx x) r 966 | 967 | {- 968 | -- | /O(n)/. A strict version of 'foldlWithKey'. 969 | foldlWithKey' :: (b -> k -> a -> b) -> b -> DMap k -> b 970 | foldlWithKey' f = go 971 | where 972 | go z Tip = z 973 | go z (Bin _ kx x l r) = z `seq` go (f (go z l) kx x) r 974 | -} 975 | 976 | {-------------------------------------------------------------------- 977 | List variations 978 | --------------------------------------------------------------------} 979 | 980 | -- | /O(n)/. Return all keys of the map in ascending order. 981 | -- 982 | -- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] 983 | -- > keys empty == [] 984 | 985 | keys :: DMap k f -> [Some k] 986 | keys m 987 | = [mkSome k | (k :=> _) <- assocs m] 988 | 989 | -- | /O(n)/. Return all key\/value pairs in the map in ascending key order. 990 | assocs :: DMap k f -> [DSum k f] 991 | assocs m 992 | = toList m 993 | 994 | {-------------------------------------------------------------------- 995 | Lists 996 | use [foldlStrict] to reduce demand on the control-stack 997 | --------------------------------------------------------------------} 998 | 999 | -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. 1000 | -- If the list contains more than one value for the same key, the last value 1001 | -- for the key is retained. 1002 | fromList :: GCompare k => [DSum k f] -> DMap k f 1003 | fromList xs 1004 | = foldlStrict ins empty xs 1005 | where 1006 | ins :: GCompare k => DMap k f -> DSum k f -> DMap k f 1007 | ins t (k :=> x) = insert k x t 1008 | 1009 | -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. 1010 | fromListWithKey :: GCompare k => (forall v. k v -> f v -> f v -> f v) -> [DSum k f] -> DMap k f 1011 | fromListWithKey f xs 1012 | = foldlStrict (ins f) empty xs 1013 | where 1014 | ins :: GCompare k => (forall v. k v -> f v -> f v -> f v) -> DMap k f -> DSum k f -> DMap k f 1015 | ins f t (k :=> x) = insertWithKey f k x t 1016 | 1017 | -- | /O(n)/. Convert to a list of key\/value pairs. 1018 | toList :: DMap k f -> [DSum k f] 1019 | toList t = toAscList t 1020 | 1021 | -- | /O(n)/. Convert to an ascending list. 1022 | toAscList :: DMap k f -> [DSum k f] 1023 | toAscList t = foldrWithKey (\k x xs -> (k :=> x):xs) [] t 1024 | 1025 | -- | /O(n)/. Convert to a descending list. 1026 | toDescList :: DMap k f -> [DSum k f] 1027 | toDescList t = foldlWithKey (\xs k x -> (k :=> x):xs) [] t 1028 | 1029 | {-------------------------------------------------------------------- 1030 | Building trees from ascending/descending lists can be done in linear time. 1031 | 1032 | Note that if [xs] is ascending that: 1033 | fromAscList xs == fromList xs 1034 | fromAscListWith f xs == fromListWith f xs 1035 | --------------------------------------------------------------------} 1036 | 1037 | -- | /O(n)/. Build a map from an ascending list in linear time. 1038 | -- /The precondition (input list is ascending) is not checked./ 1039 | fromAscList :: GEq k => [DSum k f] -> DMap k f 1040 | fromAscList xs 1041 | = fromAscListWithKey (\_ x _ -> x) xs 1042 | 1043 | -- | /O(n)/. Build a map from an ascending list in linear time with a 1044 | -- combining function for equal keys. 1045 | -- /The precondition (input list is ascending) is not checked./ 1046 | fromAscListWithKey :: GEq k => (forall v. k v -> f v -> f v -> f v) -> [DSum k f] -> DMap k f 1047 | fromAscListWithKey f xs 1048 | = fromDistinctAscList (combineEq f xs) 1049 | where 1050 | -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] 1051 | combineEq _ xs' 1052 | = case xs' of 1053 | [] -> [] 1054 | [x] -> [x] 1055 | (x:xx) -> combineEq' f x xx 1056 | 1057 | combineEq' :: GEq k => (forall v. k v -> f v -> f v -> f v) -> DSum k f -> [DSum k f] -> [DSum k f] 1058 | combineEq' f z [] = [z] 1059 | combineEq' f z@(kz :=> zz) (x@(kx :=> xx):xs') = 1060 | case geq kx kz of 1061 | Just Refl -> let yy = f kx xx zz in combineEq' f (kx :=> yy) xs' 1062 | Nothing -> z : combineEq' f x xs' 1063 | 1064 | 1065 | -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. 1066 | -- /The precondition is not checked./ 1067 | fromDistinctAscList :: [DSum k f] -> DMap k f 1068 | fromDistinctAscList xs 1069 | = build const (length xs) xs 1070 | where 1071 | -- 1) use continutations so that we use heap space instead of stack space. 1072 | -- 2) special case for n==5 to build bushier trees. 1073 | 1074 | build :: (DMap k f -> [DSum k f] -> b) -> Int -> [DSum k f] -> b 1075 | build c 0 xs' = c Tip xs' 1076 | build c 5 xs' = case xs' of 1077 | ((k1:=>x1):(k2:=>x2):(k3:=>x3):(k4:=>x4):(k5:=>x5):xx) 1078 | -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx 1079 | _ -> error "fromDistinctAscList build" 1080 | build c n xs' = seq nr $ build (buildR nr c) nl xs' 1081 | where 1082 | nl = n `div` 2 1083 | nr = n - nl - 1 1084 | 1085 | buildR :: Int -> (DMap k f -> [DSum k f] -> b) -> DMap k f -> [DSum k f] -> b 1086 | buildR n c l ((k:=>x):ys) = build (buildB l k x c) n ys 1087 | buildR _ _ _ [] = error "fromDistinctAscList buildR []" 1088 | 1089 | buildB :: DMap k f -> k v -> f v -> (DMap k f -> a -> b) -> DMap k f -> a -> b 1090 | buildB l k x c r zs = c (bin k x l r) zs 1091 | 1092 | {-------------------------------------------------------------------- 1093 | Split 1094 | --------------------------------------------------------------------} 1095 | 1096 | -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where 1097 | -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. 1098 | -- Any key equal to @k@ is found in neither @map1@ nor @map2@. 1099 | split :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, DMap k f) 1100 | split k = toPair . go 1101 | where 1102 | go :: DMap k f -> (DMap k f :*: DMap k f) 1103 | go Tip = (Tip :*: Tip) 1104 | go (Bin _ kx x l r) = case gcompare k kx of 1105 | GLT -> let !(lt :*: gt) = go l in (lt :*: combine kx x gt r) 1106 | GGT -> let !(lt :*: gt) = go r in (combine kx x l lt :*: gt) 1107 | GEQ -> (l :*: r) 1108 | {-# INLINABLE split #-} 1109 | 1110 | -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just 1111 | -- like 'split' but also returns @'lookup' k map@. 1112 | splitLookup :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, Maybe (f v), DMap k f) 1113 | splitLookup k = toTriple . go 1114 | where 1115 | go :: DMap k f -> Triple' (DMap k f) (Maybe (f v)) (DMap k f) 1116 | go Tip = Triple' Tip Nothing Tip 1117 | go (Bin _ kx x l r) = case gcompare k kx of 1118 | GLT -> let !(Triple' lt z gt) = go l in Triple' lt z (combine kx x gt r) 1119 | GGT -> let !(Triple' lt z gt) = go r in Triple' (combine kx x l lt) z gt 1120 | GEQ -> Triple' l (Just x) r 1121 | 1122 | -- | /O(log n)/. The expression (@'splitMember' k map@) splits a map just 1123 | -- like 'split' but also returns @'member' k map@. 1124 | splitMember :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, Bool, DMap k f) 1125 | splitMember k = toTriple . go 1126 | where 1127 | go :: DMap k f -> Triple' (DMap k f) Bool (DMap k f) 1128 | go Tip = Triple' Tip False Tip 1129 | go (Bin _ kx x l r) = case gcompare k kx of 1130 | GLT -> let !(Triple' lt z gt) = go l in Triple' lt z (combine kx x gt r) 1131 | GGT -> let !(Triple' lt z gt) = go r in Triple' (combine kx x l lt) z gt 1132 | GEQ -> Triple' l True r 1133 | 1134 | -- | /O(log n)/. 1135 | splitLookupWithKey :: forall k f v. GCompare k => k v -> DMap k f -> (DMap k f, Maybe (k v, f v), DMap k f) 1136 | splitLookupWithKey k = toTriple . go 1137 | where 1138 | go :: DMap k f -> Triple' (DMap k f) (Maybe (k v, f v)) (DMap k f) 1139 | go Tip = Triple' Tip Nothing Tip 1140 | go (Bin _ kx x l r) = case gcompare k kx of 1141 | GLT -> let !(Triple' lt z gt) = go l in Triple' lt z (combine kx x gt r) 1142 | GGT -> let !(Triple' lt z gt) = go r in Triple' (combine kx x l lt) z gt 1143 | GEQ -> Triple' l (Just (kx, x)) r 1144 | 1145 | {-------------------------------------------------------------------- 1146 | Eq converts the tree to a list. In a lazy setting, this 1147 | actually seems one of the faster methods to compare two trees 1148 | and it is certainly the simplest :-) 1149 | --------------------------------------------------------------------} 1150 | instance (GEq k, Has' Eq k f) => Eq (DMap k f) where 1151 | t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) 1152 | 1153 | {-------------------------------------------------------------------- 1154 | Ord 1155 | --------------------------------------------------------------------} 1156 | 1157 | instance (GCompare k, Has' Eq k f, Has' Ord k f) => Ord (DMap k f) where 1158 | compare m1 m2 = compare (toAscList m1) (toAscList m2) 1159 | 1160 | {-------------------------------------------------------------------- 1161 | Read 1162 | --------------------------------------------------------------------} 1163 | 1164 | instance (GCompare k, GRead k, Has' Read k f) => Read (DMap k f) where 1165 | readPrec = parens $ prec 10 $ do 1166 | Ident "fromList" <- lexP 1167 | xs <- readPrec 1168 | return (fromList xs) 1169 | 1170 | readListPrec = readListPrecDefault 1171 | 1172 | {-------------------------------------------------------------------- 1173 | Show 1174 | --------------------------------------------------------------------} 1175 | instance (GShow k, Has' Show k f) => Show (DMap k f) where 1176 | showsPrec p m = showParen (p>10) 1177 | ( showString "fromList " 1178 | . showsPrec 11 (toList m) 1179 | ) 1180 | 1181 | -- | /O(n)/. Show the tree that implements the map. The tree is shown 1182 | -- in a compressed, hanging format. See 'showTreeWith'. 1183 | showTree :: (GShow k, Has' Show k f) => DMap k f -> String 1184 | showTree m 1185 | = showTreeWith showElem True False m 1186 | where 1187 | showElem :: (GShow k, Has' Show k f) => k v -> f v -> String 1188 | showElem k x = show (k :=> x) 1189 | 1190 | 1191 | {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows 1192 | the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 1193 | 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If 1194 | @wide@ is 'True', an extra wide version is shown. 1195 | -} 1196 | showTreeWith :: (forall v. k v -> f v -> String) -> Bool -> Bool -> DMap k f -> String 1197 | showTreeWith showelem hang wide t 1198 | | hang = (showsTreeHang showelem wide [] t) "" 1199 | | otherwise = (showsTree showelem wide [] [] t) "" 1200 | 1201 | showsTree :: (forall v. k v -> f v -> String) -> Bool -> [String] -> [String] -> DMap k f -> ShowS 1202 | showsTree showelem wide lbars rbars t 1203 | = case t of 1204 | Tip -> showsBars lbars . showString "|\n" 1205 | Bin _ kx x Tip Tip 1206 | -> showsBars lbars . showString (showelem kx x) . showString "\n" 1207 | Bin _ kx x l r 1208 | -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . 1209 | showWide wide rbars . 1210 | showsBars lbars . showString (showelem kx x) . showString "\n" . 1211 | showWide wide lbars . 1212 | showsTree showelem wide (withEmpty lbars) (withBar lbars) l 1213 | 1214 | showsTreeHang :: (forall v. k v -> f v -> String) -> Bool -> [String] -> DMap k f -> ShowS 1215 | showsTreeHang showelem wide bars t 1216 | = case t of 1217 | Tip -> showsBars bars . showString "|\n" 1218 | Bin _ kx x Tip Tip 1219 | -> showsBars bars . showString (showelem kx x) . showString "\n" 1220 | Bin _ kx x l r 1221 | -> showsBars bars . showString (showelem kx x) . showString "\n" . 1222 | showWide wide bars . 1223 | showsTreeHang showelem wide (withBar bars) l . 1224 | showWide wide bars . 1225 | showsTreeHang showelem wide (withEmpty bars) r 1226 | 1227 | showWide :: Bool -> [String] -> String -> String 1228 | showWide wide bars 1229 | | wide = showString (concat (reverse bars)) . showString "|\n" 1230 | | otherwise = id 1231 | 1232 | showsBars :: [String] -> ShowS 1233 | showsBars bars 1234 | = case bars of 1235 | [] -> id 1236 | _ -> showString (concat (reverse (tail bars))) . showString node 1237 | 1238 | node :: String 1239 | node = "+--" 1240 | 1241 | withBar, withEmpty :: [String] -> [String] 1242 | withBar bars = "| ":bars 1243 | withEmpty bars = " ":bars 1244 | 1245 | {-------------------------------------------------------------------- 1246 | Assertions 1247 | --------------------------------------------------------------------} 1248 | 1249 | -- | /O(n)/. Test if the internal map structure is valid. 1250 | valid :: GCompare k => DMap k f -> Bool 1251 | valid t 1252 | = balanced t && ordered t && validsize t 1253 | 1254 | ordered :: GCompare k => DMap k f -> Bool 1255 | ordered t 1256 | = bounded (const True) (const True) t 1257 | where 1258 | bounded :: GCompare k => (Some k -> Bool) -> (Some k -> Bool) -> DMap k f -> Bool 1259 | bounded lo hi t' 1260 | = case t' of 1261 | Tip -> True 1262 | Bin _ kx _ l r -> lo (mkSome kx) && hi (mkSome kx) && bounded lo (< mkSome kx) l && bounded (> mkSome kx) hi r 1263 | 1264 | -- | Exported only for "Debug.QuickCheck" 1265 | balanced :: DMap k f -> Bool 1266 | balanced t 1267 | = case t of 1268 | Tip -> True 1269 | Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && 1270 | balanced l && balanced r 1271 | 1272 | validsize :: DMap k f -> Bool 1273 | validsize t 1274 | = (realsize t == Just (size t)) 1275 | where 1276 | realsize t' 1277 | = case t' of 1278 | Tip -> Just 0 1279 | Bin sz _ _ l r -> case (realsize l,realsize r) of 1280 | (Just n,Just m) | n+m+1 == sz -> Just sz 1281 | _ -> Nothing 1282 | {-------------------------------------------------------------------- 1283 | Utilities 1284 | --------------------------------------------------------------------} 1285 | foldlStrict :: (a -> b -> a) -> a -> [b] -> a 1286 | foldlStrict f = go 1287 | where 1288 | go z [] = z 1289 | go z (x:xs) = z `seq` go (f z x) xs 1290 | -------------------------------------------------------------------------------- /src/Data/Dependent/Map/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE Safe #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | module Data.Dependent.Map.Internal where 9 | 10 | import Data.Dependent.Sum (DSum((:=>))) 11 | import Data.GADT.Compare (GCompare, GOrdering(..), gcompare) 12 | import Data.Some (Some, mkSome, withSome) 13 | import Data.Typeable (Typeable) 14 | 15 | -- |Dependent maps: 'k' is a GADT-like thing with a facility for 16 | -- rediscovering its type parameter, elements of which function as identifiers 17 | -- tagged with the type of the thing they identify. Real GADTs are one 18 | -- useful instantiation of @k@, as are 'Tag's from "Data.Unique.Tag" in the 19 | -- 'prim-uniq' package. 20 | -- 21 | -- Semantically, @'DMap' k f@ is equivalent to a set of @'DSum' k f@ where no two 22 | -- elements have the same tag. 23 | -- 24 | -- More informally, 'DMap' is to dependent products as 'M.Map' is to @(->)@. 25 | -- Thus it could also be thought of as a partial (in the sense of \"partial 26 | -- function\") dependent product. 27 | data DMap k f where 28 | Tip :: DMap k f 29 | Bin :: {- sz -} !Int 30 | -> {- key -} !(k v) 31 | -> {- value -} f v 32 | -> {- left -} !(DMap k f) 33 | -> {- right -} !(DMap k f) 34 | -> DMap k f 35 | deriving Typeable 36 | 37 | {-------------------------------------------------------------------- 38 | Construction 39 | --------------------------------------------------------------------} 40 | 41 | -- | /O(1)/. The empty map. 42 | -- 43 | -- > empty == fromList [] 44 | -- > size empty == 0 45 | empty :: DMap k f 46 | empty = Tip 47 | 48 | -- | /O(1)/. A map with a single element. 49 | -- 50 | -- > singleton 1 'a' == fromList [(1, 'a')] 51 | -- > size (singleton 1 'a') == 1 52 | singleton :: k v -> f v -> DMap k f 53 | singleton k x = Bin 1 k x Tip Tip 54 | 55 | {-------------------------------------------------------------------- 56 | Query 57 | --------------------------------------------------------------------} 58 | 59 | -- | /O(1)/. Is the map empty? 60 | null :: DMap k f -> Bool 61 | null Tip = True 62 | null Bin{} = False 63 | 64 | -- | /O(1)/. The number of elements in the map. 65 | size :: DMap k f -> Int 66 | size Tip = 0 67 | size (Bin n _ _ _ _) = n 68 | 69 | -- | /O(log n)/. Lookup the value at a key in the map. 70 | -- 71 | -- The function will return the corresponding value as @('Just' value)@, 72 | -- or 'Nothing' if the key isn't in the map. 73 | lookup :: forall k f v. GCompare k => k v -> DMap k f -> Maybe (f v) 74 | lookup k = k `seq` go 75 | where 76 | go :: DMap k f -> Maybe (f v) 77 | go Tip = Nothing 78 | go (Bin _ kx x l r) = 79 | case gcompare k kx of 80 | GLT -> go l 81 | GGT -> go r 82 | GEQ -> Just x 83 | 84 | lookupAssoc :: forall k f v. GCompare k => Some k -> DMap k f -> Maybe (DSum k f) 85 | lookupAssoc sk = withSome sk $ \k -> 86 | let 87 | go :: DMap k f -> Maybe (DSum k f) 88 | go Tip = Nothing 89 | go (Bin _ kx x l r) = 90 | case gcompare k kx of 91 | GLT -> go l 92 | GGT -> go r 93 | GEQ -> Just (kx :=> x) 94 | in k `seq` go 95 | 96 | {-------------------------------------------------------------------- 97 | Utility functions that maintain the balance properties of the tree. 98 | All constructors assume that all values in [l] < [k] and all values 99 | in [r] > [k], and that [l] and [r] are valid trees. 100 | 101 | In order of sophistication: 102 | [Bin sz k x l r] The type constructor. 103 | [bin k x l r] Maintains the correct size, assumes that both [l] 104 | and [r] are balanced with respect to each other. 105 | [balance k x l r] Restores the balance and size. 106 | Assumes that the original tree was balanced and 107 | that [l] or [r] has changed by at most one element. 108 | [combine k x l r] Restores balance and size. 109 | 110 | Furthermore, we can construct a new tree from two trees. Both operations 111 | assume that all values in [l] < all values in [r] and that [l] and [r] 112 | are valid: 113 | [glue l r] Glues [l] and [r] together. Assumes that [l] and 114 | [r] are already balanced with respect to each other. 115 | [merge l r] Merges two trees and restores balance. 116 | 117 | Note: in contrast to Adam's paper, we use (<=) comparisons instead 118 | of (<) comparisons in [combine], [merge] and [balance]. 119 | Quickcheck (on [difference]) showed that this was necessary in order 120 | to maintain the invariants. It is quite unsatisfactory that I haven't 121 | been able to find out why this is actually the case! Fortunately, it 122 | doesn't hurt to be a bit more conservative. 123 | --------------------------------------------------------------------} 124 | 125 | {-------------------------------------------------------------------- 126 | Combine 127 | --------------------------------------------------------------------} 128 | combine :: GCompare k => k v -> f v -> DMap k f -> DMap k f -> DMap k f 129 | combine kx x Tip r = insertMin kx x r 130 | combine kx x l Tip = insertMax kx x l 131 | combine kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz) 132 | | delta*sizeL <= sizeR = balance kz z (combine kx x l lz) rz 133 | | delta*sizeR <= sizeL = balance ky y ly (combine kx x ry r) 134 | | otherwise = bin kx x l r 135 | 136 | 137 | -- insertMin and insertMax don't perform potentially expensive comparisons. 138 | insertMax,insertMin :: k v -> f v -> DMap k f -> DMap k f 139 | insertMax kx x t 140 | = case t of 141 | Tip -> singleton kx x 142 | Bin _ ky y l r 143 | -> balance ky y l (insertMax kx x r) 144 | 145 | insertMin kx x t 146 | = case t of 147 | Tip -> singleton kx x 148 | Bin _ ky y l r 149 | -> balance ky y (insertMin kx x l) r 150 | 151 | {-------------------------------------------------------------------- 152 | [merge l r]: merges two trees. 153 | --------------------------------------------------------------------} 154 | merge :: DMap k f -> DMap k f -> DMap k f 155 | merge Tip r = r 156 | merge l Tip = l 157 | merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry) 158 | | delta*sizeL <= sizeR = balance ky y (merge l ly) ry 159 | | delta*sizeR <= sizeL = balance kx x lx (merge rx r) 160 | | otherwise = glue l r 161 | 162 | {-------------------------------------------------------------------- 163 | [glue l r]: glues two trees together. 164 | Assumes that [l] and [r] are already balanced with respect to each other. 165 | --------------------------------------------------------------------} 166 | glue :: DMap k f -> DMap k f -> DMap k f 167 | glue Tip r = r 168 | glue l Tip = l 169 | glue l r 170 | | size l > size r = case deleteFindMax l of (km :=> m,l') -> balance km m l' r 171 | | otherwise = case deleteFindMin r of (km :=> m,r') -> balance km m l r' 172 | 173 | -- | /O(log n)/. Delete and find the minimal element. 174 | -- 175 | -- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) 176 | -- > deleteFindMin Error: can not return the minimal element of an empty map 177 | 178 | deleteFindMin :: DMap k f -> (DSum k f, DMap k f) 179 | deleteFindMin t = case minViewWithKey t of 180 | Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip) 181 | Just p -> p 182 | 183 | -- | A strict pair. 184 | data (:*:) a b = !a :*: !b 185 | infixr 1 :*: 186 | 187 | -- | Convert a strict pair to a pair. 188 | toPair :: a :*: b -> (a, b) 189 | toPair (a :*: b) = (a, b) 190 | {-# INLINE toPair #-} 191 | 192 | data Triple' a b c = Triple' !a !b !c 193 | 194 | -- | Convert a strict triple to a triple. 195 | toTriple :: Triple' a b c -> (a, b, c) 196 | toTriple (Triple' a b c) = (a, b, c) 197 | {-# INLINE toTriple #-} 198 | 199 | -- | /O(log n)/. Retrieves the minimal (key :=> value) entry of the map, and 200 | -- the map stripped of that element, or 'Nothing' if passed an empty map. 201 | minViewWithKey :: forall k f . DMap k f -> Maybe (DSum k f, DMap k f) 202 | minViewWithKey Tip = Nothing 203 | minViewWithKey (Bin _ k0 x0 l0 r0) = Just $! toPair $ go k0 x0 l0 r0 204 | where 205 | go :: k v -> f v -> DMap k f -> DMap k f -> DSum k f :*: DMap k f 206 | go k x Tip r = (k :=> x) :*: r 207 | go k x (Bin _ kl xl ll lr) r = 208 | let !(km :*: l') = go kl xl ll lr 209 | in (km :*: balance k x l' r) 210 | 211 | -- | /O(log n)/. Retrieves the maximal (key :=> value) entry of the map, and 212 | -- the map stripped of that element, or 'Nothing' if passed an empty map. 213 | maxViewWithKey :: forall k f . DMap k f -> Maybe (DSum k f, DMap k f) 214 | maxViewWithKey Tip = Nothing 215 | maxViewWithKey (Bin _ k0 x0 l0 r0) = Just $! toPair $ go k0 x0 l0 r0 216 | where 217 | go :: k v -> f v -> DMap k f -> DMap k f -> DSum k f :*: DMap k f 218 | go k x l Tip = (k :=> x) :*: l 219 | go k x l (Bin _ kr xr rl rr) = 220 | let !(km :*: r') = go kr xr rl rr 221 | in (km :*: balance k x l r') 222 | 223 | -- | /O(log n)/. Delete and find the maximal element. 224 | -- 225 | -- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")]) 226 | -- > deleteFindMax empty Error: can not return the maximal element of an empty map 227 | 228 | deleteFindMax :: DMap k f -> (DSum k f, DMap k f) 229 | deleteFindMax t 230 | = case t of 231 | Bin _ k x l Tip -> (k :=> x,l) 232 | Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r') 233 | Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip) 234 | 235 | 236 | {-------------------------------------------------------------------- 237 | [balance l x r] balances two trees with value x. 238 | The sizes of the trees should balance after decreasing the 239 | size of one of them. (a rotation). 240 | 241 | [delta] is the maximal relative difference between the sizes of 242 | two trees, it corresponds with the [w] in Adams' paper. 243 | [ratio] is the ratio between an outer and inner sibling of the 244 | heavier subtree in an unbalanced setting. It determines 245 | whether a double or single rotation should be performed 246 | to restore balance. It corresponds with the inverse 247 | of $\alpha$ in Adam's article. 248 | 249 | Note that: 250 | - [delta] should be larger than 4.646 with a [ratio] of 2. 251 | - [delta] should be larger than 3.745 with a [ratio] of 1.534. 252 | 253 | - A lower [delta] leads to a more 'perfectly' balanced tree. 254 | - A higher [delta] performs less rebalancing. 255 | 256 | - Balancing is automatic for random data and a balancing 257 | scheme is only necessary to avoid pathological worst cases. 258 | Almost any choice will do, and in practice, a rather large 259 | [delta] may perform better than smaller one. 260 | 261 | Note: in contrast to Adam's paper, we use a ratio of (at least) [2] 262 | to decide whether a single or double rotation is needed. Although 263 | he actually proves that this ratio is needed to maintain the 264 | invariants, his implementation uses an invalid ratio of [1]. 265 | --------------------------------------------------------------------} 266 | delta,ratio :: Int 267 | delta = 4 268 | ratio = 2 269 | 270 | balance :: k v -> f v -> DMap k f -> DMap k f -> DMap k f 271 | balance k x l r 272 | | sizeL + sizeR <= 1 = Bin sizeX k x l r 273 | | sizeR >= delta*sizeL = rotateL k x l r 274 | | sizeL >= delta*sizeR = rotateR k x l r 275 | | otherwise = Bin sizeX k x l r 276 | where 277 | sizeL = size l 278 | sizeR = size r 279 | sizeX = sizeL + sizeR + 1 280 | 281 | -- rotate 282 | rotateL :: k v -> f v -> DMap k f -> DMap k f -> DMap k f 283 | rotateL k x l r@(Bin _ _ _ ly ry) 284 | | size ly < ratio*size ry = singleL k x l r 285 | | otherwise = doubleL k x l r 286 | rotateL _ _ _ Tip = error "rotateL Tip" 287 | 288 | rotateR :: k v -> f v -> DMap k f -> DMap k f -> DMap k f 289 | rotateR k x l@(Bin _ _ _ ly ry) r 290 | | size ry < ratio*size ly = singleR k x l r 291 | | otherwise = doubleR k x l r 292 | rotateR _ _ Tip _ = error "rotateR Tip" 293 | 294 | -- basic rotations 295 | singleL, singleR :: k v -> f v -> DMap k f -> DMap k f -> DMap k f 296 | singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3 297 | singleL _ _ _ Tip = error "singleL Tip" 298 | singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3) 299 | singleR _ _ Tip _ = error "singleR Tip" 300 | 301 | doubleL, doubleR :: k v -> f v -> DMap k f -> DMap k f -> DMap k f 302 | doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4) 303 | doubleL _ _ _ _ = error "doubleL" 304 | doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4) 305 | doubleR _ _ _ _ = error "doubleR" 306 | 307 | {-------------------------------------------------------------------- 308 | The bin constructor maintains the size of the tree 309 | --------------------------------------------------------------------} 310 | bin :: k v -> f v -> DMap k f -> DMap k f -> DMap k f 311 | bin k x l r 312 | = Bin (size l + size r + 1) k x l r 313 | 314 | {-------------------------------------------------------------------- 315 | Utility functions that return sub-ranges of the original 316 | tree. Some functions take a comparison function as argument to 317 | allow comparisons against infinite values. A function [cmplo k] 318 | should be read as [compare lo k]. 319 | 320 | [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT] 321 | and [cmphi k == GT] for the key [k] of the root. 322 | [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT] 323 | [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT] 324 | 325 | [split k t] Returns two trees [l] and [r] where all keys 326 | in [l] are <[k] and all keys in [r] are >[k]. 327 | [splitLookup k t] Just like [split] but also returns whether [k] 328 | was found in the tree. 329 | --------------------------------------------------------------------} 330 | 331 | {-------------------------------------------------------------------- 332 | [trim lo hi t] trims away all subtrees that surely contain no 333 | values between the range [lo] to [hi]. The returned tree is either 334 | empty or the key of the root is between @lo@ and @hi@. 335 | --------------------------------------------------------------------} 336 | trim :: (Some k -> Ordering) -> (Some k -> Ordering) -> DMap k f -> DMap k f 337 | trim _ _ Tip = Tip 338 | trim cmplo cmphi t@(Bin _ kx _ l r) 339 | = case cmplo (mkSome kx) of 340 | LT -> case cmphi (mkSome kx) of 341 | GT -> t 342 | _ -> trim cmplo cmphi l 343 | _ -> trim cmplo cmphi r 344 | 345 | trimLookupLo :: GCompare k => Some k -> (Some k -> Ordering) -> DMap k f -> (Maybe (DSum k f), DMap k f) 346 | trimLookupLo _ _ Tip = (Nothing,Tip) 347 | trimLookupLo lo cmphi t@(Bin _ kx x l r) 348 | = case compare lo (mkSome kx) of 349 | LT -> case cmphi (mkSome kx) of 350 | GT -> (lookupAssoc lo t, t) 351 | _ -> trimLookupLo lo cmphi l 352 | GT -> trimLookupLo lo cmphi r 353 | EQ -> (Just (kx :=> x),trim (compare lo) cmphi r) 354 | 355 | 356 | {-------------------------------------------------------------------- 357 | [filterGt k t] filter all keys >[k] from tree [t] 358 | [filterLt k t] filter all keys <[k] from tree [t] 359 | --------------------------------------------------------------------} 360 | filterGt :: GCompare k => (Some k -> Ordering) -> DMap k f -> DMap k f 361 | filterGt cmp = go 362 | where 363 | go Tip = Tip 364 | go (Bin _ kx x l r) = case cmp (mkSome kx) of 365 | LT -> combine kx x (go l) r 366 | GT -> go r 367 | EQ -> r 368 | 369 | filterLt :: GCompare k => (Some k -> Ordering) -> DMap k f -> DMap k f 370 | filterLt cmp = go 371 | where 372 | go Tip = Tip 373 | go (Bin _ kx x l r) = case cmp (mkSome kx) of 374 | LT -> go l 375 | GT -> combine kx x l (go r) 376 | EQ -> l 377 | -------------------------------------------------------------------------------- /src/Data/Dependent/Map/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | -- | 3 | -- Some functions for using lenses with 'DMap'. 4 | module Data.Dependent.Map.Lens 5 | ( -- * At 6 | dmat 7 | -- * Ix 8 | , dmix 9 | ) 10 | where 11 | 12 | import Prelude hiding (lookup) 13 | 14 | import Data.Dependent.Map (DMap, alterF, insert, lookup) 15 | 16 | import Data.GADT.Compare (GCompare) 17 | 18 | -- | 19 | -- These functions have been specialised for use with 'DMap' but without any of the 20 | -- specific 'lens' types used so that we have compatibility without needing the 21 | -- dependency just for these functions. 22 | -- 23 | 24 | -- | 25 | -- This is equivalent to the from : 26 | -- 27 | -- @ 28 | -- type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t 29 | -- 30 | -- at :: Index m -> Lens' m (Maybe (IxValue m)) 31 | -- @ 32 | -- 33 | -- So the type of 'dmat' is equivalent to: 34 | -- 35 | -- @ 36 | -- dmat :: GCompare k => Lens' (DMap k f) (Maybe (f v)) 37 | -- @ 38 | -- 39 | -- >>> DMap.fromList [AInt :=> Identity 33, AFloat :=> Identity 3.5] & dmat AString ?~ "Hat" 40 | -- DMap.fromList [AString :=> Identity "Hat", AInt :=> Identity 33, AFloat :=> Identity 3.5] 41 | -- 42 | -- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] ^? dmat AFloat 43 | -- Just (AFloat :=> 3.5) 44 | -- 45 | dmat :: (GCompare k, Functor f) => k v -> (Maybe (g v) -> f (Maybe (g v))) -> DMap k g -> f (DMap k g) 46 | dmat k f = alterF k f 47 | {-# INLINE dmat #-} 48 | 49 | -- | 50 | -- This is equivalent to the from : 51 | -- 52 | -- @ 53 | -- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t 54 | -- 55 | -- ix :: Index m -> Traversal' m (IxValue m) 56 | -- @ 57 | -- 58 | -- So the type of 'dmix' is equivalent to: 59 | -- 60 | -- @ 61 | -- dmix :: GCompare k => k v -> Traversal' (DMap k f) (f v) 62 | -- @ 63 | -- 64 | -- /NB:/ Setting the value of this 65 | -- 66 | -- will only set the value in 'dmix' if it is already present. 67 | -- 68 | -- If you want to be able to insert /missing/ values, you want 'dmat'. 69 | -- 70 | -- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] & dmix AInt %~ f 71 | -- DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity (f 33), AFloat :=> Identity 3.5] 72 | -- 73 | -- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] & dmix AString .~ "Hat" 74 | -- DMap.fromList [AString :=> Identity "Hat", AInt :=> Identity 33, AFloat :=> Identity 3.5] 75 | -- 76 | -- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] ^? dmix AFloat 77 | -- Just (AFloat :=> 3.5) 78 | -- 79 | -- >>> DMap.fromList [AString :=> Identity "Shoe", AFloat :=> Identity 3.5] ^? dmix AInt 80 | -- Nothing 81 | dmix :: (GCompare k, Applicative f) => k v -> (g v -> f (g v)) -> DMap k g -> f (DMap k g) 82 | dmix k f dmap = maybe (pure dmap) (fmap (flip (insert k) dmap) . f) $ lookup k dmap 83 | {-# INLINE dmix #-} 84 | -------------------------------------------------------------------------------- /src/Data/Dependent/Map/PtrEquality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | {-# OPTIONS_HADDOCK hide #-} 4 | 5 | -- | Really unsafe pointer equality 6 | -- 7 | -- = WARNING 8 | -- 9 | -- This module is considered __internal__. 10 | -- 11 | -- The Package Versioning Policy __does not apply__. 12 | -- 13 | -- The contents of this module may change __in any way whatsoever__ 14 | -- and __without any warning__ between minor versions of this package. 15 | -- 16 | -- Authors importing this module are expected to track development 17 | -- closely. 18 | 19 | module Data.Dependent.Map.PtrEquality (ptrEq, hetPtrEq) where 20 | 21 | import Unsafe.Coerce (unsafeCoerce) 22 | import GHC.Exts (isTrue#, reallyUnsafePtrEquality#) 23 | 24 | 25 | -- | Checks if two pointers are equal. Yes means yes; 26 | -- no means maybe. The values should be forced to at least 27 | -- WHNF before comparison to get moderately reliable results. 28 | ptrEq :: a -> a -> Bool 29 | 30 | -- | Checks if two pointers are equal, without requiring 31 | -- them to have the same type. The values should be forced 32 | -- to at least WHNF before comparison to get moderately 33 | -- reliable results. 34 | hetPtrEq :: a -> b -> Bool 35 | 36 | ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y) 37 | hetPtrEq x y = isTrue# (unsafeCoerce reallyUnsafePtrEquality# x y) 38 | 39 | {-# INLINE ptrEq #-} 40 | {-# INLINE hetPtrEq #-} 41 | 42 | infix 4 `ptrEq` 43 | infix 4 `hetPtrEq` 44 | -------------------------------------------------------------------------------- /src/Data/Dependent/Map/Typeable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | module Data.Dependent.Map.Typeable where 3 | 4 | import Data.Dependent.Map.Internal 5 | import Data.Typeable 6 | 7 | instance (Typeable1 k, Typeable1 f) => Typeable (DMap k f) where 8 | typeOf ds = mkTyConApp dMapCon [typeOfK, typeOfF] 9 | where 10 | typeOfK = typeOf1 $ (undefined :: DMap k f -> k a) ds 11 | typeOfF = typeOf1 $ (undefined :: DMap k f -> f a) ds 12 | dMapCon = mkTyCon3 "dependent-map" "Data.Dependent.Map" "DMap" 13 | --------------------------------------------------------------------------------