├── .gitignore ├── cabal.project ├── unpacked-containers ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── bin │ └── docs.sh ├── example │ ├── Int.hs │ └── Main.hs ├── include │ └── containers.h ├── perf │ └── set.txt ├── src │ ├── Key.hsig │ ├── Map.hs │ ├── Map │ │ ├── Internal.hs │ │ ├── Internal │ │ │ └── Debug.hs │ │ ├── Lazy.hs │ │ ├── Merge │ │ │ ├── Lazy.hs │ │ │ └── Strict.hs │ │ ├── Strict.hs │ │ └── Strict │ │ │ └── Internal.hs │ ├── Set.hs │ └── Set │ │ └── Internal.hs ├── unpacked-containers.cabal └── utils │ └── Internal │ ├── BitQueue.hs │ ├── BitUtil.hs │ ├── PtrEquality.hs │ ├── State.hs │ ├── StrictFold.hs │ ├── StrictMaybe.hs │ └── StrictPair.hs └── unpacked-unordered-containers ├── CHANGELOG.md ├── LICENSE ├── README.md ├── src ├── HashMap │ ├── Base.hs │ ├── Lazy.hs │ └── Strict.hs ├── HashSet.hs └── Key.hsig ├── unpacked-unordered-containers.cabal └── utils └── Internal ├── Array.hs ├── List.hs └── UnsafeShift.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | .coda_history 3 | .DS_Store 4 | .hsenv 5 | .stack-work 6 | .tags 7 | .vscode-test 8 | *.coda 9 | *.o 10 | *.hi 11 | *.log 12 | *.swo 13 | *.swp 14 | *.vsix 15 | *~ 16 | *# 17 | cabal.project.local 18 | cabal.sandbox.config 19 | codex.tags 20 | dist 21 | dist-newstyle 22 | docs 23 | node_modules 24 | old 25 | out 26 | tags 27 | TODO.txt 28 | wiki 29 | wip 30 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | unpacked-containers/unpacked-containers.cabal 3 | unpacked-unordered-containers/unpacked-unordered-containers.cabal 4 | 5 | package unpacked-containers 6 | optimization: True 7 | 8 | package unpacked-unordered-containers 9 | optimization: True 10 | -------------------------------------------------------------------------------- /unpacked-containers/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0 2 | 3 | * repository initialized 4 | -------------------------------------------------------------------------------- /unpacked-containers/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2018, Edward Kmett 2 | (c) 2002 Daan Leijen 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are 8 | met: 9 | 10 | * Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. 17 | 18 | * Neither the name of Edward Kmett nor the names of other 19 | contributors may be used to endorse or promote products derived 20 | from this software without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 30 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 31 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 32 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /unpacked-containers/Makefile: -------------------------------------------------------------------------------- 1 | all: build 2 | 3 | build: 4 | cabal new-build 5 | 6 | clean: 7 | rm -rf dist dist-newstyle 8 | 9 | docs: 10 | cabal new-haddock 11 | cp -aRv dist-newstyle/build/*/*/unpacked-containers-0/doc/html/unpacked-containers/* docs 12 | cd docs && git commit -a -m "update haddocks" && git push && cd .. 13 | 14 | .PHONY: all build clean docs 15 | -------------------------------------------------------------------------------- /unpacked-containers/README.md: -------------------------------------------------------------------------------- 1 | unpacked-containers 2 | == 3 | 4 | This package supplies a simple unpacked version of `Data.Set` and `Data.Map` using backpack. 5 | 6 | This can remove a level of indirection on the heap and unpack your keys directly into nodes of your sets and maps. 7 | 8 | The exported modules roughly follow the API of `containers 0.5.11`, but with all deprecated functions removed. 9 | 10 | Note however, that all CPP has been removed relative to `containers`, because on one hand, use of backpack locks us to a current version of GHC, 11 | and on the other there is a bug in GHC 8.2.2 that prevents the use of CPP in a module that uses backpack. This issue is resolved in GHC 8.4.1, 12 | so as that comes into wider usage if we need to track `containers` API changes going forward and those need CPP we can just drop support for 8.2.2. 13 | 14 | It is intended that you will remap the names of the modules. from `Set.*` or `Map.*` to some portion of the namespace that is peculiar to your 15 | project, and so the module names are designed to be as short as possible, mirroring the usage of `containers` but with the `Data` prefix stripped off. 16 | 17 | Usage 18 | ----- 19 | 20 | To work this into an existing haskell project, you'll need to be on GHC >= 8.2.2, and use cabal >= 2. 21 | 22 | First build an internal library for your project that has a module that matches the `Key` signature. 23 | 24 | ``` 25 | module MyKey where 26 | 27 | type Key = () 28 | ``` 29 | 30 | You can put whatever you want in for `Key` as long as it is an instance of `Ord`. 31 | 32 | Then in your cabal file you can set up your internal library as an extra named internal library (multiple library support was added in cabal 2). 33 | 34 | ``` 35 | library my-keys 36 | exposed-modules: MyKey 37 | build-depends: base 38 | ``` 39 | 40 | and in your library or executable that wants to work with sets or maps of that key type use 41 | 42 | 43 | ``` 44 | library 45 | build-depends: unpacked-containers, my-keys 46 | mixins: unpacked-containers (Set as MyKey.Set) requires (Key as MyKey) 47 | ``` 48 | 49 | If you need several `Set`s or `Map`s you can use several `mixins:` clauses. 50 | 51 | If you need to expose the set type, remember you can use a `reexported-modules:` stanza. 52 | 53 | Now you work with `MyKey.Set` as a monomorphic set type specific to the type of `Key` you specified earlier. 54 | 55 | See the `executable unpacked-set-example` and `library example` sections in the `unpacked-containers.cabal` file for a minimal working example. 56 | 57 | Documentation 58 | == 59 | 60 | To build haddocks for this project you need to run `cabal new-haddock` as `cabal-haddock` doesn't work. 61 | 62 | Contact Information 63 | ------------------- 64 | 65 | Contributions and bug reports are welcome! 66 | 67 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 68 | 69 | -Edward Kmett 70 | -------------------------------------------------------------------------------- /unpacked-containers/bin/docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | cabal new-haddock --haddock-for-hackage --haddock-option=--hyperlinked-source 3 | cabal upload -d dist-newstyle/unpacked-containers-*-docs.tar.gz --publish 4 | -------------------------------------------------------------------------------- /unpacked-containers/example/Int.hs: -------------------------------------------------------------------------------- 1 | module Int where 2 | 3 | type Key = Int 4 | -------------------------------------------------------------------------------- /unpacked-containers/example/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Int.Set 4 | 5 | ten :: Set 6 | ten = fromList [1..10] 7 | 8 | main :: IO () 9 | main = print ten 10 | -------------------------------------------------------------------------------- /unpacked-containers/include/containers.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Common macros for containers 3 | */ 4 | 5 | #ifndef HASKELL_CONTAINERS_H 6 | #define HASKELL_CONTAINERS_H 7 | 8 | /* 9 | * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro. 10 | */ 11 | #ifdef __GLASGOW_HASKELL__ 12 | #include "MachDeps.h" 13 | #endif 14 | 15 | /* 16 | * Define INSTANCE_TYPEABLE[0-2] 17 | */ 18 | #if __GLASGOW_HASKELL__ >= 707 19 | #define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon 20 | #define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable tycon 21 | #define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable tycon 22 | #elif defined(__GLASGOW_HASKELL__) 23 | #define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon 24 | #define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable1 tycon 25 | #define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable2 tycon 26 | #else 27 | #define INSTANCE_TYPEABLE0(tycon) 28 | #define INSTANCE_TYPEABLE1(tycon) 29 | #define INSTANCE_TYPEABLE2(tycon) 30 | #endif 31 | 32 | #if __GLASGOW_HASKELL__ >= 800 33 | #define DEFINE_PATTERN_SYNONYMS 1 34 | #endif 35 | 36 | /* 37 | * We use cabal-generated MIN_VERSION_base to adapt to changes of base. 38 | * Nevertheless, as a convenience, we also allow compiling without cabal by 39 | * defining an approximate MIN_VERSION_base if needed. The alternative version 40 | * guesses the version of base using the version of GHC. This is usually 41 | * sufficiently accurate. However, it completely ignores minor version numbers, 42 | * and it makes the assumption that a pre-release version of GHC will ship with 43 | * base libraries with the same version numbers as the final release. This 44 | * assumption is violated in certain stages of GHC development, but in practice 45 | * this should very rarely matter, and will not affect any released version. 46 | */ 47 | #ifndef MIN_VERSION_base 48 | #if __GLASGOW_HASKELL__ >= 709 49 | #define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=8))) 50 | #elif __GLASGOW_HASKELL__ >= 707 51 | #define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=7))) 52 | #elif __GLASGOW_HASKELL__ >= 705 53 | #define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=6))) 54 | #elif __GLASGOW_HASKELL__ >= 703 55 | #define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=5))) 56 | #elif __GLASGOW_HASKELL__ >= 701 57 | #define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=4))) 58 | #elif __GLASGOW_HASKELL__ >= 700 59 | #define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=3))) 60 | #else 61 | #define MIN_VERSION_base(major1,major2,minor) (0) 62 | #endif 63 | #endif 64 | 65 | #endif 66 | -------------------------------------------------------------------------------- /unpacked-containers/src/Key.hsig: -------------------------------------------------------------------------------- 1 | signature Key where 2 | 3 | data Key 4 | instance Eq Key 5 | instance Ord Key 6 | -------------------------------------------------------------------------------- /unpacked-containers/src/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Map 6 | -- Copyright : (c) Daan Leijen 2002 7 | -- (c) Andriy Palamarchuk 2008 8 | -- (c) Edward Kmett 2018 9 | -- License : BSD-style 10 | -- Maintainer : libraries@haskell.org 11 | -- Portability : portable 12 | -- 13 | -- /Note:/ You should use "Map.Strict" instead of this module if: 14 | -- 15 | -- * You will eventually need all the values stored. 16 | -- 17 | -- * The stored values don't represent large virtual data structures 18 | -- to be lazily computed. 19 | -- 20 | -- An efficient implementation of ordered maps from keys to values 21 | -- (dictionaries). 22 | -- 23 | -- These modules are intended to be imported qualified, to avoid name 24 | -- clashes with Prelude functions, e.g. 25 | -- 26 | -- > import qualified Map as Map 27 | -- 28 | -- The implementation of 'Map' is based on /size balanced/ binary trees (or 29 | -- trees of /bounded balance/) as described by: 30 | -- 31 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 32 | -- Journal of Functional Programming 3(4):553-562, October 1993, 33 | -- . 34 | -- * J. Nievergelt and E.M. Reingold, 35 | -- \"/Binary search trees of bounded balance/\", 36 | -- SIAM journal of computing 2(1), March 1973. 37 | -- 38 | -- Bounds for 'union', 'intersection', and 'difference' are as given 39 | -- by 40 | -- 41 | -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun, 42 | -- \"/Just Join for Parallel Ordered Sets/\", 43 | -- . 44 | -- 45 | -- Note that the implementation is /left-biased/ -- the elements of a 46 | -- first argument are always preferred to the second, for example in 47 | -- 'union' or 'insert'. 48 | -- 49 | -- /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of 50 | -- this condition is not detected and if the size limit is exceeded, its 51 | -- behaviour is undefined. 52 | -- 53 | -- Operation comments contain the operation time complexity in 54 | -- the Big-O notation (). 55 | ----------------------------------------------------------------------------- 56 | 57 | module Map 58 | ( module Map.Lazy 59 | ) where 60 | 61 | import Prelude hiding (foldr) 62 | import Map.Lazy 63 | -------------------------------------------------------------------------------- /unpacked-containers/src/Map/Internal/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} 3 | module Map.Internal.Debug where 4 | 5 | import Key 6 | import Map.Internal (Map (..), size, delta) 7 | import Control.Monad (guard) 8 | 9 | -- | /O(n)/. Show the tree that implements the map. The tree is shown 10 | -- in a compressed, hanging format. See 'showTreeWith'. 11 | showTree :: (Show Key, Show a) => Map a -> String 12 | showTree m 13 | = showTreeWith showElem True False m 14 | where 15 | showElem k x = show k ++ ":=" ++ show x 16 | 17 | 18 | {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows 19 | the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 20 | 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If 21 | @wide@ is 'True', an extra wide version is shown. 22 | 23 | > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]] 24 | > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t 25 | > (4,()) 26 | > +--(2,()) 27 | > | +--(1,()) 28 | > | +--(3,()) 29 | > +--(5,()) 30 | > 31 | > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t 32 | > (4,()) 33 | > | 34 | > +--(2,()) 35 | > | | 36 | > | +--(1,()) 37 | > | | 38 | > | +--(3,()) 39 | > | 40 | > +--(5,()) 41 | > 42 | > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t 43 | > +--(5,()) 44 | > | 45 | > (4,()) 46 | > | 47 | > | +--(3,()) 48 | > | | 49 | > +--(2,()) 50 | > | 51 | > +--(1,()) 52 | 53 | -} 54 | showTreeWith :: (Key -> a -> String) -> Bool -> Bool -> Map a -> String 55 | showTreeWith showelem hang wide t 56 | | hang = (showsTreeHang showelem wide [] t) "" 57 | | otherwise = (showsTree showelem wide [] [] t) "" 58 | 59 | showsTree :: (Key -> a -> String) -> Bool -> [String] -> [String] -> Map a -> ShowS 60 | showsTree showelem wide lbars rbars t 61 | = case t of 62 | Tip -> showsBars lbars . showString "|\n" 63 | Bin _ kx x Tip Tip 64 | -> showsBars lbars . showString (showelem kx x) . showString "\n" 65 | Bin _ kx x l r 66 | -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . 67 | showWide wide rbars . 68 | showsBars lbars . showString (showelem kx x) . showString "\n" . 69 | showWide wide lbars . 70 | showsTree showelem wide (withEmpty lbars) (withBar lbars) l 71 | 72 | showsTreeHang :: (Key -> a -> String) -> Bool -> [String] -> Map a -> ShowS 73 | showsTreeHang showelem wide bars t 74 | = case t of 75 | Tip -> showsBars bars . showString "|\n" 76 | Bin _ kx x Tip Tip 77 | -> showsBars bars . showString (showelem kx x) . showString "\n" 78 | Bin _ kx x l r 79 | -> showsBars bars . showString (showelem kx x) . showString "\n" . 80 | showWide wide bars . 81 | showsTreeHang showelem wide (withBar bars) l . 82 | showWide wide bars . 83 | showsTreeHang showelem wide (withEmpty bars) r 84 | 85 | showWide :: Bool -> [String] -> String -> String 86 | showWide wide bars 87 | | wide = showString (concat (reverse bars)) . showString "|\n" 88 | | otherwise = id 89 | 90 | showsBars :: [String] -> ShowS 91 | showsBars bars 92 | = case bars of 93 | [] -> id 94 | _ -> showString (concat (reverse (tail bars))) . showString node 95 | 96 | node :: String 97 | node = "+--" 98 | 99 | withBar, withEmpty :: [String] -> [String] 100 | withBar bars = "| ":bars 101 | withEmpty bars = " ":bars 102 | 103 | {-------------------------------------------------------------------- 104 | Assertions 105 | --------------------------------------------------------------------} 106 | -- | /O(n)/. Test if the internal map structure is valid. 107 | -- 108 | -- > valid (fromAscList [(3,"b"), (5,"a")]) == True 109 | -- > valid (fromAscList [(5,"a"), (3,"b")]) == False 110 | 111 | valid :: Map a -> Bool 112 | valid t = balanced t && ordered t && validsize t 113 | 114 | -- | Test if the keys are ordered correctly. 115 | ordered :: Map b -> Bool 116 | ordered t 117 | = bounded (const True) (const True) t 118 | where 119 | bounded lo hi t' 120 | = case t' of 121 | Tip -> True 122 | Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (kx) hi r 123 | 124 | -- | Test if a map obeys the balance invariants. 125 | balanced :: Map a -> Bool 126 | balanced t 127 | = case t of 128 | Tip -> True 129 | Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && 130 | balanced l && balanced r 131 | 132 | -- | Test if each node of a map reports its size correctly. 133 | validsize :: Map b -> Bool 134 | validsize t = case slowSize t of 135 | Nothing -> False 136 | Just _ -> True 137 | where 138 | slowSize Tip = Just 0 139 | slowSize (Bin sz _ _ l r) = do 140 | ls <- slowSize l 141 | rs <- slowSize r 142 | guard (sz == ls + rs + 1) 143 | return sz 144 | -------------------------------------------------------------------------------- /unpacked-containers/src/Map/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Map.Lazy 6 | -- Copyright : (c) Daan Leijen 2002 7 | -- (c) Andriy Palamarchuk 2008 8 | -- License : BSD-style 9 | -- Maintainer : libraries@haskell.org 10 | -- Portability : portable 11 | -- 12 | -- 13 | -- = Finite Maps (lazy interface) 14 | -- 15 | -- The @'Map' k v@ type represents a finite map (sometimes called a dictionary) 16 | -- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy 17 | -- in its values. 18 | -- 19 | -- The functions in "Map.Strict" are careful to force values before 20 | -- installing them in a 'Map'. This is usually more efficient in cases where 21 | -- laziness is not essential. The functions in this module do not do so. 22 | -- 23 | -- When deciding if this is the correct data structure to use, consider: 24 | -- 25 | -- * If you are using 'Int' keys, you will get much better performance for most 26 | -- operations using "Data.IntMap.Lazy". 27 | -- 28 | -- * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the 29 | -- 30 | -- package instead. 31 | -- 32 | -- For a walkthrough of the most commonly used functions see the 33 | -- . 34 | -- 35 | -- This module is intended to be imported qualified, to avoid name clashes with 36 | -- Prelude functions: 37 | -- 38 | -- > import qualified Map.Lazy as Map 39 | -- 40 | -- Note that the implementation is generally /left-biased/. Functions that take 41 | -- two maps as arguments and combine them, such as `union` and `intersection`, 42 | -- prefer the values in the first argument to those in the second. 43 | -- 44 | -- 45 | -- == Detailed performance information 46 | -- 47 | -- The amortized running time is given for each operation, with /n/ referring to 48 | -- the number of entries in the map. 49 | -- 50 | -- Benchmarks comparing "Map.Lazy" with other dictionary implementations 51 | -- can be found at https://github.com/haskell-perf/dictionaries. 52 | -- 53 | -- 54 | -- == Warning 55 | -- 56 | -- The size of a 'Map' must not exceed @maxBound::Int@. Violation of this 57 | -- condition is not detected and if the size limit is exceeded, its behaviour is 58 | -- undefined. 59 | -- 60 | -- 61 | -- == Implementation 62 | -- 63 | -- The implementation of 'Map' is based on /size balanced/ binary trees (or 64 | -- trees of /bounded balance/) as described by: 65 | -- 66 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 67 | -- Journal of Functional Programming 3(4):553-562, October 1993, 68 | -- . 69 | -- * J. Nievergelt and E.M. Reingold, 70 | -- \"/Binary search trees of bounded balance/\", 71 | -- SIAM journal of computing 2(1), March 1973. 72 | -- 73 | -- Bounds for 'union', 'intersection', and 'difference' are as given 74 | -- by 75 | -- 76 | -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun, 77 | -- \"/Just Join for Parallel Ordered Sets/\", 78 | -- . 79 | -- 80 | ----------------------------------------------------------------------------- 81 | 82 | module Map.Lazy ( 83 | -- * Map type 84 | Map -- instance Eq,Show,Read 85 | 86 | -- * Operators 87 | , (!), (!?), (\\) 88 | 89 | -- * Query 90 | , null 91 | , size 92 | , member 93 | , notMember 94 | , lookup 95 | , findWithDefault 96 | , lookupLT 97 | , lookupGT 98 | , lookupLE 99 | , lookupGE 100 | 101 | -- * Construction 102 | , empty 103 | , singleton 104 | 105 | -- ** Insertion 106 | , insert 107 | , insertWith 108 | , insertWithKey 109 | , insertLookupWithKey 110 | 111 | -- ** Delete\/Update 112 | , delete 113 | , adjust 114 | , adjustWithKey 115 | , update 116 | , updateWithKey 117 | , updateLookupWithKey 118 | , alter 119 | , alterF 120 | 121 | -- * Combine 122 | 123 | -- ** Union 124 | , union 125 | , unionWith 126 | , unionWithKey 127 | , unions 128 | , unionsWith 129 | 130 | -- ** Difference 131 | , difference 132 | , differenceWith 133 | , differenceWithKey 134 | 135 | -- ** Intersection 136 | , intersection 137 | , intersectionWith 138 | , intersectionWithKey 139 | 140 | -- ** General combining functions 141 | -- | See "Map.Merge.Lazy" 142 | 143 | -- ** Unsafe general combining function 144 | 145 | , mergeWithKey 146 | 147 | -- * Traversal 148 | -- ** Map 149 | , map 150 | , mapWithKey 151 | , traverseWithKey 152 | , traverseMaybeWithKey 153 | , mapAccum 154 | , mapAccumWithKey 155 | , mapAccumRWithKey 156 | , mapKeys 157 | , mapKeysWith 158 | , mapKeysMonotonic 159 | 160 | -- * Folds 161 | , foldr 162 | , foldl 163 | , foldrWithKey 164 | , foldlWithKey 165 | , foldMapWithKey 166 | 167 | -- ** Strict folds 168 | , foldr' 169 | , foldl' 170 | , foldrWithKey' 171 | , foldlWithKey' 172 | 173 | -- * Conversion 174 | , elems 175 | , keys 176 | , assocs 177 | , keysSet 178 | , fromSet 179 | 180 | -- ** Lists 181 | , toList 182 | , fromList 183 | , fromListWith 184 | , fromListWithKey 185 | 186 | -- ** Ordered lists 187 | , toAscList 188 | , toDescList 189 | , fromAscList 190 | , fromAscListWith 191 | , fromAscListWithKey 192 | , fromDistinctAscList 193 | , fromDescList 194 | , fromDescListWith 195 | , fromDescListWithKey 196 | , fromDistinctDescList 197 | 198 | -- * Filter 199 | , filter 200 | , filterWithKey 201 | , restrictKeys 202 | , withoutKeys 203 | , partition 204 | , partitionWithKey 205 | , takeWhileAntitone 206 | , dropWhileAntitone 207 | , spanAntitone 208 | 209 | , mapMaybe 210 | , mapMaybeWithKey 211 | , mapEither 212 | , mapEitherWithKey 213 | 214 | , split 215 | , splitLookup 216 | , splitRoot 217 | 218 | -- * Submap 219 | , isSubmapOf, isSubmapOfBy 220 | , isProperSubmapOf, isProperSubmapOfBy 221 | 222 | -- * Indexed 223 | , lookupIndex 224 | , findIndex 225 | , elemAt 226 | , updateAt 227 | , deleteAt 228 | , take 229 | , drop 230 | , splitAt 231 | 232 | -- * Min\/Max 233 | , lookupMin 234 | , lookupMax 235 | , findMin 236 | , findMax 237 | , deleteMin 238 | , deleteMax 239 | , deleteFindMin 240 | , deleteFindMax 241 | , updateMin 242 | , updateMax 243 | , updateMinWithKey 244 | , updateMaxWithKey 245 | , minView 246 | , maxView 247 | , minViewWithKey 248 | , maxViewWithKey 249 | 250 | -- * Debugging 251 | , valid 252 | ) where 253 | 254 | import Map.Internal 255 | import Map.Internal.Debug (valid) 256 | import Prelude () 257 | -------------------------------------------------------------------------------- /unpacked-containers/src/Map/Merge/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE MagicHash #-} 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Map.Merge.Lazy 11 | -- Copyright : (c) David Feuer 2016 12 | -- License : BSD-style 13 | -- Maintainer : libraries@haskell.org 14 | -- Portability : portable 15 | -- 16 | -- This module defines an API for writing functions that merge two 17 | -- maps. The key functions are 'merge' and 'mergeA'. 18 | -- Each of these can be used with several different \"merge tactics\". 19 | -- 20 | -- The 'merge' and 'mergeA' functions are shared by 21 | -- the lazy and strict modules. Only the choice of merge tactics 22 | -- determines strictness. If you use 'Map.Merge.Strict.mapMissing' 23 | -- from "Map.Merge.Strict" then the results will be forced before 24 | -- they are inserted. If you use 'Map.Merge.Lazy.mapMissing' from 25 | -- this module then they will not. 26 | -- 27 | -- == Efficiency note 28 | -- 29 | -- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' 30 | -- tactics are included because they are valid. However, they are 31 | -- inefficient in many cases and should usually be avoided. The instances 32 | -- for 'WhenMatched' tactics should not pose any major efficiency problems. 33 | -- 34 | -- @since 0.5.9 35 | 36 | module Map.Merge.Lazy ( 37 | -- ** Simple merge tactic types 38 | SimpleWhenMissing 39 | , SimpleWhenMatched 40 | 41 | -- ** General combining function 42 | , merge 43 | 44 | -- *** @WhenMatched@ tactics 45 | , zipWithMaybeMatched 46 | , zipWithMatched 47 | 48 | -- *** @WhenMissing@ tactics 49 | , mapMaybeMissing 50 | , dropMissing 51 | , preserveMissing 52 | , mapMissing 53 | , filterMissing 54 | 55 | -- ** Applicative merge tactic types 56 | , WhenMissing 57 | , WhenMatched 58 | 59 | -- ** Applicative general combining function 60 | , mergeA 61 | 62 | -- *** @WhenMatched@ tactics 63 | -- | The tactics described for 'merge' work for 64 | -- 'mergeA' as well. Furthermore, the following 65 | -- are available. 66 | , zipWithMaybeAMatched 67 | , zipWithAMatched 68 | 69 | -- *** @WhenMissing@ tactics 70 | -- | The tactics described for 'merge' work for 71 | -- 'mergeA' as well. Furthermore, the following 72 | -- are available. 73 | , traverseMaybeMissing 74 | , traverseMissing 75 | , filterAMissing 76 | 77 | -- *** Covariant maps for tactics 78 | , mapWhenMissing 79 | , mapWhenMatched 80 | 81 | -- *** Contravariant maps for tactics 82 | , lmapWhenMissing 83 | , contramapFirstWhenMatched 84 | , contramapSecondWhenMatched 85 | 86 | -- *** Miscellaneous tactic functions 87 | , runWhenMatched 88 | , runWhenMissing 89 | ) where 90 | 91 | import Map.Internal 92 | -------------------------------------------------------------------------------- /unpacked-containers/src/Map/Merge/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE MagicHash #-} 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Map.Merge.Strict 11 | -- Copyright : (c) David Feuer 2016 12 | -- License : BSD-style 13 | -- Maintainer : libraries@haskell.org 14 | -- Portability : portable 15 | -- 16 | -- This module defines an API for writing functions that merge two 17 | -- maps. The key functions are 'merge' and 'mergeA'. 18 | -- Each of these can be used with several different \"merge tactics\". 19 | -- 20 | -- The 'merge' and 'mergeA' functions are shared by 21 | -- the lazy and strict modules. Only the choice of merge tactics 22 | -- determines strictness. If you use 'Map.Merge.Strict.mapMissing' 23 | -- from this module then the results will be forced before they are 24 | -- inserted. If you use 'Map.Merge.Lazy.mapMissing' from 25 | -- "Map.Merge.Lazy" then they will not. 26 | -- 27 | -- == Efficiency note 28 | -- 29 | -- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' 30 | -- tactics are included because they are valid. However, they are 31 | -- inefficient in many cases and should usually be avoided. The instances 32 | -- for 'WhenMatched' tactics should not pose any major efficiency problems. 33 | -- 34 | -- @since 0.5.9 35 | 36 | module Map.Merge.Strict ( 37 | -- ** Simple merge tactic types 38 | SimpleWhenMissing 39 | , SimpleWhenMatched 40 | 41 | -- ** General combining function 42 | , merge 43 | 44 | -- *** @WhenMatched@ tactics 45 | , zipWithMaybeMatched 46 | , zipWithMatched 47 | 48 | -- *** @WhenMissing@ tactics 49 | , mapMaybeMissing 50 | , dropMissing 51 | , preserveMissing 52 | , mapMissing 53 | , filterMissing 54 | 55 | -- ** Applicative merge tactic types 56 | , WhenMissing 57 | , WhenMatched 58 | 59 | -- ** Applicative general combining function 60 | , mergeA 61 | 62 | -- *** @WhenMatched@ tactics 63 | -- | The tactics described for 'merge' work for 64 | -- 'mergeA' as well. Furthermore, the following 65 | -- are available. 66 | , zipWithMaybeAMatched 67 | , zipWithAMatched 68 | 69 | -- *** @WhenMissing@ tactics 70 | -- | The tactics described for 'merge' work for 71 | -- 'mergeA' as well. Furthermore, the following 72 | -- are available. 73 | , traverseMaybeMissing 74 | , traverseMissing 75 | , filterAMissing 76 | 77 | -- ** Covariant maps for tactics 78 | , mapWhenMissing 79 | , mapWhenMatched 80 | 81 | -- ** Miscellaneous functions on tactics 82 | 83 | , runWhenMatched 84 | , runWhenMissing 85 | ) where 86 | 87 | import Map.Strict.Internal 88 | -------------------------------------------------------------------------------- /unpacked-containers/src/Map/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Map.Strict 7 | -- Copyright : (c) Daan Leijen 2002 8 | -- (c) Andriy Palamarchuk 2008 9 | -- (c) Edward Kmett 2018 10 | -- License : BSD-style 11 | -- Maintainer : libraries@haskell.org 12 | -- Portability : portable 13 | -- 14 | -- 15 | -- = Finite Maps (strict interface) 16 | -- 17 | -- The @'Map' v@ type represents a finite map (sometimes called a dictionary) 18 | -- from keys of type @k@ to values of type @v@. 19 | -- 20 | -- Each function in this module is careful to force values before installing 21 | -- them in a 'Map'. This is usually more efficient when laziness is not 22 | -- necessary. When laziness /is/ required, use the functions in "Map.Lazy". 23 | -- 24 | -- In particular, the functions in this module obey the following law: 25 | -- 26 | -- - If all values stored in all maps in the arguments are in WHNF, then all 27 | -- values stored in all maps in the results will be in WHNF once those maps 28 | -- are evaluated. 29 | -- 30 | -- When deciding if this is the correct data structure to use, consider: 31 | -- 32 | -- * If you are using 'Int' keys, you will get much better performance for most 33 | -- operations using "Data.IntMap.Strict". 34 | -- 35 | -- * If you don't care about ordering, consider use @Data.HashMap.Strict@ from the 36 | -- 37 | -- package instead. 38 | -- 39 | -- For a walkthrough of the most commonly used functions see the 40 | -- . 41 | -- 42 | -- This module is intended to be imported qualified, to avoid name clashes with 43 | -- Prelude functions: 44 | -- 45 | -- > import qualified Map.Strict as Map 46 | -- 47 | -- Note that the implementation is generally /left-biased/. Functions that take 48 | -- two maps as arguments and combine them, such as `union` and `intersection`, 49 | -- prefer the values in the first argument to those in the second. 50 | -- 51 | -- 52 | -- == Detailed performance information 53 | -- 54 | -- The amortized running time is given for each operation, with /n/ referring to 55 | -- the number of entries in the map. 56 | -- 57 | -- == Warning 58 | -- 59 | -- The size of a 'Map' must not exceed @maxBound::Int@. Violation of this 60 | -- condition is not detected and if the size limit is exceeded, its behaviour is 61 | -- undefined. 62 | -- 63 | -- The 'Map' type is shared between the lazy and strict modules, meaning that 64 | -- the same 'Map' value can be passed to functions in both modules. This means 65 | -- that the 'Functor', 'Traversable' and 'Data' instances are the same as for 66 | -- the "Map.Lazy" module, so if they are used on strict maps, the resulting 67 | -- maps may contain suspended values (thunks). 68 | -- 69 | -- 70 | -- == Implementation 71 | -- 72 | -- The implementation of 'Map' is based on /size balanced/ binary trees (or 73 | -- trees of /bounded balance/) as described by: 74 | -- 75 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 76 | -- Journal of Functional Programming 3(4):553-562, October 1993, 77 | -- . 78 | -- * J. Nievergelt and E.M. Reingold, 79 | -- \"/Binary search trees of bounded balance/\", 80 | -- SIAM journal of computing 2(1), March 1973. 81 | -- 82 | -- Bounds for 'union', 'intersection', and 'difference' are as given 83 | -- by 84 | -- 85 | -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun, 86 | -- \"/Just Join for Parallel Ordered Sets/\", 87 | -- . 88 | -- 89 | -- 90 | ----------------------------------------------------------------------------- 91 | 92 | -- See the notes at the beginning of Map.Internal. 93 | 94 | module Map.Strict 95 | ( 96 | -- * Map type 97 | Map -- instance Eq,Show,Read 98 | 99 | -- * Operators 100 | , (!), (!?), (\\) 101 | 102 | -- * Query 103 | , null 104 | , size 105 | , member 106 | , notMember 107 | , lookup 108 | , findWithDefault 109 | , lookupLT 110 | , lookupGT 111 | , lookupLE 112 | , lookupGE 113 | 114 | -- * Construction 115 | , empty 116 | , singleton 117 | 118 | -- ** Insertion 119 | , insert 120 | , insertWith 121 | , insertWithKey 122 | , insertLookupWithKey 123 | 124 | -- ** Delete\/Update 125 | , delete 126 | , adjust 127 | , adjustWithKey 128 | , update 129 | , updateWithKey 130 | , updateLookupWithKey 131 | , alter 132 | , alterF 133 | 134 | -- * Combine 135 | 136 | -- ** Union 137 | , union 138 | , unionWith 139 | , unionWithKey 140 | , unions 141 | , unionsWith 142 | 143 | -- ** Difference 144 | , difference 145 | , differenceWith 146 | , differenceWithKey 147 | 148 | -- ** Intersection 149 | , intersection 150 | , intersectionWith 151 | , intersectionWithKey 152 | 153 | -- ** General combining functions 154 | -- | See "Map.Merge.Strict" 155 | 156 | -- ** Deprecated general combining function 157 | 158 | , mergeWithKey 159 | 160 | -- * Traversal 161 | -- ** Map 162 | , map 163 | , mapWithKey 164 | , traverseWithKey 165 | , traverseMaybeWithKey 166 | , mapAccum 167 | , mapAccumWithKey 168 | , mapAccumRWithKey 169 | , mapKeys 170 | , mapKeysWith 171 | , mapKeysMonotonic 172 | 173 | -- * Folds 174 | , foldr 175 | , foldl 176 | , foldrWithKey 177 | , foldlWithKey 178 | , foldMapWithKey 179 | 180 | -- ** Strict folds 181 | , foldr' 182 | , foldl' 183 | , foldrWithKey' 184 | , foldlWithKey' 185 | 186 | -- * Conversion 187 | , elems 188 | , keys 189 | , assocs 190 | , keysSet 191 | , fromSet 192 | 193 | -- ** Lists 194 | , toList 195 | , fromList 196 | , fromListWith 197 | , fromListWithKey 198 | 199 | -- ** Ordered lists 200 | , toAscList 201 | , toDescList 202 | , fromAscList 203 | , fromAscListWith 204 | , fromAscListWithKey 205 | , fromDistinctAscList 206 | , fromDescList 207 | , fromDescListWith 208 | , fromDescListWithKey 209 | , fromDistinctDescList 210 | 211 | -- * Filter 212 | , filter 213 | , filterWithKey 214 | , restrictKeys 215 | , withoutKeys 216 | , partition 217 | , partitionWithKey 218 | 219 | , takeWhileAntitone 220 | , dropWhileAntitone 221 | , spanAntitone 222 | 223 | , mapMaybe 224 | , mapMaybeWithKey 225 | , mapEither 226 | , mapEitherWithKey 227 | 228 | , split 229 | , splitLookup 230 | , splitRoot 231 | 232 | -- * Submap 233 | , isSubmapOf, isSubmapOfBy 234 | , isProperSubmapOf, isProperSubmapOfBy 235 | 236 | -- * Indexed 237 | , lookupIndex 238 | , findIndex 239 | , elemAt 240 | , updateAt 241 | , deleteAt 242 | , take 243 | , drop 244 | , splitAt 245 | 246 | -- * Min\/Max 247 | , lookupMin 248 | , lookupMax 249 | , findMin 250 | , findMax 251 | , deleteMin 252 | , deleteMax 253 | , deleteFindMin 254 | , deleteFindMax 255 | , updateMin 256 | , updateMax 257 | , updateMinWithKey 258 | , updateMaxWithKey 259 | , minView 260 | , maxView 261 | , minViewWithKey 262 | , maxViewWithKey 263 | 264 | -- * Debugging 265 | , valid 266 | ) where 267 | 268 | import Map.Strict.Internal 269 | import Prelude () 270 | -------------------------------------------------------------------------------- /unpacked-containers/src/Set.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Set 4 | -- Copyright : (c) Daan Leijen 2002, (c) Edward Kmett 2017-2018 5 | -- 6 | -- License : BSD-style 7 | -- Maintainer : libraries@haskell.org 8 | -- Portability : portable 9 | -- 10 | -- An efficient implementation of sets using backpack to unpack the element type 11 | -- 12 | -- These modules are intended to be imported qualified, to avoid name 13 | -- clashes with Prelude functions, e.g. 14 | -- 15 | -- > import Data.Set (Set) 16 | -- > import qualified Data.Set as Set 17 | -- 18 | -- The implementation of 'Set' is based on /size balanced/ binary trees (or 19 | -- trees of /bounded balance/) as described by: 20 | -- 21 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 22 | -- Journal of Functional Programming 3(4):553-562, October 1993, 23 | -- . 24 | -- * J. Nievergelt and E.M. Reingold, 25 | -- \"/Binary search trees of bounded balance/\", 26 | -- SIAM journal of computing 2(1), March 1973. 27 | -- 28 | -- Bounds for 'union', 'intersection', and 'difference' are as given 29 | -- by 30 | -- 31 | -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun, 32 | -- \"/Just Join for Parallel Ordered Sets/\", 33 | -- . 34 | -- 35 | -- Note that the implementation is /left-biased/ -- the elements of a 36 | -- first argument are always preferred to the second, for example in 37 | -- 'union' or 'insert'. Of course, left-biasing can only be observed 38 | -- when equality is an equivalence relation instead of structural 39 | -- equality. 40 | -- 41 | -- /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of 42 | -- this condition is not detected and if the size limit is exceeded, its 43 | -- behaviour is undefined. 44 | ----------------------------------------------------------------------------- 45 | 46 | module Set ( 47 | -- * Strictness properties 48 | -- $strictness 49 | 50 | -- * Set type 51 | Set 52 | 53 | -- * Operators 54 | , (\\) 55 | 56 | -- * Query 57 | , S.null 58 | , size 59 | , member 60 | , notMember 61 | , lookupLT 62 | , lookupGT 63 | , lookupLE 64 | , lookupGE 65 | , isSubsetOf 66 | , isProperSubsetOf 67 | 68 | -- * Construction 69 | , empty 70 | , singleton 71 | , insert 72 | , delete 73 | 74 | -- * Combine 75 | , union 76 | , unions 77 | , difference 78 | , intersection 79 | 80 | -- * Filter 81 | , S.filter 82 | , takeWhileAntitone 83 | , dropWhileAntitone 84 | , spanAntitone 85 | , partition 86 | , split 87 | , splitMember 88 | , splitRoot 89 | 90 | -- * Indexed 91 | , lookupIndex 92 | , findIndex 93 | , elemAt 94 | , deleteAt 95 | , S.take 96 | , S.drop 97 | , S.splitAt 98 | 99 | -- * Map 100 | , S.map 101 | , mapMonotonic 102 | 103 | -- * Folds 104 | , S.foldMap 105 | , S.foldr 106 | , S.foldl 107 | -- ** Strict folds 108 | , foldr' 109 | , foldl' 110 | 111 | -- * Min\/Max 112 | , lookupMin 113 | , lookupMax 114 | , findMin 115 | , findMax 116 | , deleteMin 117 | , deleteMax 118 | , deleteFindMin 119 | , deleteFindMax 120 | , maxView 121 | , minView 122 | 123 | -- * Conversion 124 | 125 | -- ** List 126 | , elems 127 | , toList 128 | , fromList 129 | 130 | -- ** Ordered list 131 | , toAscList 132 | , toDescList 133 | , fromAscList 134 | , fromDescList 135 | , fromDistinctAscList 136 | , fromDistinctDescList 137 | 138 | -- * Debugging 139 | , showTree 140 | , showTreeWith 141 | , valid 142 | ) where 143 | 144 | import Set.Internal as S 145 | 146 | -- $strictness 147 | -- 148 | -- This module satisfies the following strictness property: 149 | -- 150 | -- * Key arguments are evaluated to WHNF 151 | -- 152 | -- Here are some examples that illustrate the property: 153 | -- 154 | -- > delete undefined s == undefined 155 | -------------------------------------------------------------------------------- /unpacked-containers/src/Set/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language PatternGuards #-} 3 | {-# language TypeFamilies #-} 4 | {-# language LambdaCase #-} 5 | {-# language FlexibleContexts #-} 6 | {-# language UndecidableInstances #-} 7 | {-# language MagicHash #-} 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Set.Internal 11 | -- Copyright : (c) Daan Leijen 2002, (c) Edward Kmett 2017-2018 12 | -- License : BSD-style 13 | -- Maintainer : libraries@haskell.org 14 | -- Portability : portable 15 | -- 16 | -- An efficient implementation of unpacked sets using backpack, 17 | -- based on Data.Set.Internal from containers. 18 | -- 19 | -- These modules are intended to be imported qualified, to avoid name 20 | -- clashes with Prelude functions, e.g. 21 | -- 22 | -- > import Data.Set (Set) 23 | -- > import qualified Data.Set as Set 24 | -- 25 | -- The implementation of 'Set' is based on /size balanced/ binary trees (or 26 | -- trees of /bounded balance/) as described by: 27 | -- 28 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 29 | -- Journal of Functional Programming 3(4):553-562, October 1993, 30 | -- . 31 | -- * J. Nievergelt and E.M. Reingold, 32 | -- \"/Binary search trees of bounded balance/\", 33 | -- SIAM journal of computing 2(1), March 1973. 34 | -- 35 | -- Bounds for 'union', 'intersection', and 'difference' are as given 36 | -- by 37 | -- 38 | -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun, 39 | -- \"/Just Join for Parallel Ordered Sets/\", 40 | -- . 41 | -- 42 | -- Note that the implementation is /left-biased/ -- the elements of a 43 | -- first argument are always preferred to the second, for example in 44 | -- 'union' or 'insert'. Of course, left-biasing can only be observed 45 | -- when equality is an equivalence relation instead of structural 46 | -- equality. 47 | -- 48 | -- /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of 49 | -- this condition is not detected and if the size limit is exceeded, the 50 | -- behavior of the set is completely undefined. 51 | ----------------------------------------------------------------------------- 52 | 53 | -- [Note: Using inlinable] 54 | -- ~~~~~~~~~~~~~~~~~~~~~~~ 55 | -- It is crucial to the performance that the functions specialize on the Ord 56 | -- type when possible. GHC 7.0 and higher does this by itself when it sees th 57 | -- unfolding of a function -- that is why all public functions are marked 58 | -- inlinable (that exposes the unfolding). 59 | -- 60 | -- This isn't required here, because we get to know the Ord Key dictionary 61 | 62 | -- [Note: Using inline] 63 | -- ~~~~~~~~~~~~~~~~~~~~ 64 | -- For other compilers and GHC pre 7.0, we mark some of the functions inline. 65 | -- We mark the functions that just navigate down the tree (lookup, insert, 66 | -- delete and similar). That navigation code gets inlined and thus specialized 67 | -- when possible. There is a price to pay -- code growth. The code inlineD is 68 | -- therefore only the tree navigation, all the real work (rebalancing) is not 69 | -- inlineD by using a NOinline. 70 | -- 71 | -- All methods marked inline have to be nonrecursive -- a 'go' function doing 72 | -- the real work is provided. 73 | 74 | -- [Note: Type of local 'go' function] 75 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 76 | -- If the local 'go' function uses an Ord class, it sometimes heap-allocates 77 | -- the Ord dictionary when the 'go' function does not have explicit type. 78 | -- In that case we give 'go' explicit type. But this slightly decrease 79 | -- performance, as the resulting 'go' function can float out to top level. 80 | -- 81 | 82 | -- [Note: Local 'go' functions and capturing] 83 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 84 | -- As opposed to IntSet, when 'go' function captures an argument, increased 85 | -- heap-allocation can occur: sometimes in a polymorphic function, the 'go' 86 | -- floats out of its enclosing function and then it heap-allocates the 87 | -- dictionary and the argument. Maybe it floats out too late and strictness 88 | -- analyzer cannot see that these could be passed on stack. 89 | 90 | -- [Note: Order of constructors] 91 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 92 | -- The order of constructors of Set matters when considering performance. 93 | -- Currently in GHC 7.0, when type has 2 constructors, a forward conditional 94 | -- jump is made when successfully matching second constructor. Successful match 95 | -- of first constructor results in the forward jump not taken. 96 | -- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip 97 | -- improves the benchmark by up to 10% on x86. 98 | 99 | module Set.Internal ( 100 | -- * Set type 101 | Set(..) 102 | 103 | -- * Operators 104 | , (\\) 105 | 106 | -- * Query 107 | , null 108 | , size 109 | , member 110 | , notMember 111 | , lookupLT 112 | , lookupGT 113 | , lookupLE 114 | , lookupGE 115 | , isSubsetOf 116 | , isProperSubsetOf 117 | 118 | -- * Construction 119 | , empty 120 | , singleton 121 | , insert 122 | , delete 123 | 124 | -- * Combine 125 | , union 126 | , unions 127 | , difference 128 | , intersection 129 | 130 | -- * Filter 131 | , filter 132 | , takeWhileAntitone 133 | , dropWhileAntitone 134 | , spanAntitone 135 | , partition 136 | , split 137 | , splitMember 138 | , splitRoot 139 | 140 | -- * Indexed 141 | , lookupIndex 142 | , findIndex 143 | , elemAt 144 | , deleteAt 145 | , take 146 | , drop 147 | , splitAt 148 | 149 | -- * Map 150 | , map 151 | , mapMonotonic 152 | 153 | -- * Folds 154 | , foldMap 155 | , foldr 156 | , foldl 157 | -- ** Strict folds 158 | , foldr' 159 | , foldl' 160 | 161 | -- * Min\/Max 162 | , lookupMin 163 | , lookupMax 164 | , findMin 165 | , findMax 166 | , deleteMin 167 | , deleteMax 168 | , deleteFindMin 169 | , deleteFindMax 170 | , maxView 171 | , minView 172 | 173 | -- * Conversion 174 | 175 | -- ** List 176 | , elems 177 | , toList 178 | , fromList 179 | 180 | -- ** Ordered list 181 | , toAscList 182 | , toDescList 183 | , fromAscList 184 | , fromDistinctAscList 185 | , fromDescList 186 | , fromDistinctDescList 187 | 188 | -- * Debugging 189 | , showTree 190 | , showTreeWith 191 | , valid 192 | 193 | -- Internals (for testing) 194 | , bin 195 | , balanced 196 | , link 197 | , merge 198 | ) where 199 | 200 | import Control.DeepSeq (NFData(rnf)) 201 | import Data.Bits (shiftL, shiftR) 202 | import Data.Data 203 | import Data.Default.Class 204 | import qualified Data.List as List 205 | import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid) 206 | import GHC.Exts (build, lazy, isTrue#, reallyUnsafePtrEquality#) 207 | import qualified GHC.Exts as GHCExts 208 | import Prelude hiding (filter,foldMap,foldl,foldr,null,map,take,drop,splitAt) 209 | import Text.Read 210 | 211 | import Key 212 | 213 | -- | The same as a regular Haskell pair, but 214 | -- 215 | -- @ 216 | -- (x :*: _|_) = (_|_ :*: y) = _|_ 217 | -- @ 218 | data StrictPair a b = !a :*: !b 219 | 220 | infixr 1 :*: 221 | 222 | -- | Convert a strict pair to a standard pair. 223 | toPair :: StrictPair a b -> (a, b) 224 | toPair (x :*: y) = (x, y) 225 | {-# inline toPair #-} 226 | 227 | ptrEq :: a -> a -> Bool 228 | ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y) 229 | {-# inline ptrEq #-} 230 | 231 | {-------------------------------------------------------------------- 232 | Operators 233 | --------------------------------------------------------------------} 234 | infixl 9 \\ -- 235 | 236 | -- | /O(m*log(n\/m+1)), m <= n/. See 'difference'. 237 | (\\) :: Set -> Set -> Set 238 | (\\) = difference 239 | {-# inline (\\) #-} 240 | 241 | {-------------------------------------------------------------------- 242 | Sets are size balanced trees 243 | --------------------------------------------------------------------} 244 | -- | A set of values @a@. 245 | 246 | -- See Note: Order of constructors 247 | data Set = Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Key !Set !Set | Tip 248 | 249 | instance Default Set where 250 | def = Tip 251 | 252 | type Size = Int 253 | 254 | instance Monoid Set where 255 | mempty = empty 256 | mconcat = unions 257 | mappend = (<>) 258 | 259 | instance Semigroup Set where 260 | (<>) = union 261 | stimes = stimesIdempotentMonoid 262 | 263 | foldMap :: Monoid m => (Key -> m) -> Set -> m 264 | foldMap f t = go t where 265 | go Tip = mempty 266 | go (Bin 1 k _ _) = f k 267 | go (Bin _ k l r) = go l `mappend` (f k `mappend` go r) 268 | {-# inline foldMap #-} 269 | 270 | instance Data Key => Data Set where 271 | gfoldl f z set = z fromList `f` (toList set) 272 | toConstr _ = fromListConstr 273 | gunfold k z c = case constrIndex c of 274 | 1 -> k (z fromList) 275 | _ -> error "gunfold" 276 | dataTypeOf _ = setDataType 277 | -- dataCast1 f = gcast1 f 278 | 279 | fromListConstr :: Constr 280 | fromListConstr = mkConstr setDataType "fromList" [] Prefix 281 | 282 | setDataType :: DataType 283 | setDataType = mkDataType "Data.Set.Internal.Set" [fromListConstr] 284 | 285 | {-------------------------------------------------------------------- 286 | Query 287 | --------------------------------------------------------------------} 288 | -- | /O(1)/. Is this the empty set? 289 | null :: Set -> Bool 290 | null Tip = True 291 | null Bin {} = False 292 | {-# inline null #-} 293 | 294 | -- | /O(1)/. The number of elements in the set. 295 | size :: Set -> Int 296 | size Tip = 0 297 | size (Bin sz _ _ _) = sz 298 | {-# inline size #-} 299 | 300 | -- | /O(log n)/. Is the element in the set? 301 | member :: Key -> Set -> Bool 302 | member !_ Tip = False 303 | member x (Bin _ y l r) = case compare x y of 304 | LT -> member x l 305 | GT -> member x r 306 | EQ -> True 307 | 308 | -- | /O(log n)/. Is the element not in the set? 309 | notMember :: Key -> Set -> Bool 310 | notMember a t = not $ member a t 311 | 312 | -- | /O(log n)/. Find largest element smaller than the given one. 313 | -- 314 | -- > lookupLT 3 (fromList [3, 5]) == Nothing 315 | -- > lookupLT 5 (fromList [3, 5]) == Just 3 316 | lookupLT :: Key -> Set -> Maybe Key 317 | lookupLT = goNothing where 318 | goNothing !_ Tip = Nothing 319 | goNothing x (Bin _ y l r) 320 | | x <= y = goNothing x l 321 | | otherwise = goJust x y r 322 | goJust !_ best Tip = Just best 323 | goJust x best (Bin _ y l r) 324 | | x <= y = goJust x best l 325 | | otherwise = goJust x y r 326 | 327 | -- | /O(log n)/. Find smallest element greater than the given one. 328 | -- 329 | -- > lookupGT 4 (fromList [3, 5]) == Just 5 330 | -- > lookupGT 5 (fromList [3, 5]) == Nothing 331 | lookupGT :: Key -> Set -> Maybe Key 332 | lookupGT = goNothing where 333 | goNothing !_ Tip = Nothing 334 | goNothing x (Bin _ y l r) 335 | | x < y = goJust x y l 336 | | otherwise = goNothing x r 337 | 338 | goJust !_ best Tip = Just best 339 | goJust x best (Bin _ y l r) 340 | | x < y = goJust x y l 341 | | otherwise = goJust x best r 342 | 343 | -- | /O(log n)/. Find largest element smaller or equal to the given one. 344 | -- 345 | -- > lookupLE 2 (fromList [3, 5]) == Nothing 346 | -- > lookupLE 4 (fromList [3, 5]) == Just 3 347 | -- > lookupLE 5 (fromList [3, 5]) == Just 5 348 | lookupLE :: Key -> Set -> Maybe Key 349 | lookupLE = goNothing where 350 | goNothing !_ Tip = Nothing 351 | goNothing x (Bin _ y l r) = case compare x y of 352 | LT -> goNothing x l 353 | EQ -> Just y 354 | GT -> goJust x y r 355 | 356 | goJust !_ best Tip = Just best 357 | goJust x best (Bin _ y l r) = case compare x y of 358 | LT -> goJust x best l 359 | EQ -> Just y 360 | GT -> goJust x y r 361 | 362 | -- | /O(log n)/. Find smallest element greater or equal to the given one. 363 | -- 364 | -- > lookupGE 3 (fromList [3, 5]) == Just 3 365 | -- > lookupGE 4 (fromList [3, 5]) == Just 5 366 | -- > lookupGE 6 (fromList [3, 5]) == Nothing 367 | lookupGE :: Key -> Set -> Maybe Key 368 | lookupGE = goNothing where 369 | goNothing !_ Tip = Nothing 370 | goNothing x (Bin _ y l r) = case compare x y of 371 | LT -> goJust x y l 372 | EQ -> Just y 373 | GT -> goNothing x r 374 | 375 | goJust !_ best Tip = Just best 376 | goJust x best (Bin _ y l r) = case compare x y of 377 | LT -> goJust x y l 378 | EQ -> Just y 379 | GT -> goJust x best r 380 | 381 | {-------------------------------------------------------------------- 382 | Construction 383 | --------------------------------------------------------------------} 384 | -- | /O(1)/. The empty set. 385 | empty :: Set 386 | empty = Tip 387 | {-# inline empty #-} 388 | 389 | -- | /O(1)/. Create a singleton set. 390 | singleton :: Key -> Set 391 | singleton x = Bin 1 x Tip Tip 392 | {-# inline singleton #-} 393 | 394 | {-------------------------------------------------------------------- 395 | Insertion, Deletion 396 | --------------------------------------------------------------------} 397 | -- | /O(log n)/. Insert an element in a set. 398 | -- If the set already contains an element equal to the given value, 399 | -- it is replaced with the new value. 400 | 401 | -- See Note: Type of local 'go' function 402 | -- See Note: Avoiding worker/wrapper (in Data.Map.Internal) 403 | insert :: Key -> Set -> Set 404 | insert x0 = go x0 x0 where 405 | go :: Key -> Key -> Set -> Set 406 | go orig !_ Tip = singleton (lazy orig) 407 | go orig !x t@(Bin sz y l r) = case compare x y of 408 | LT | l' `ptrEq` l -> t 409 | | otherwise -> balanceL y l' r 410 | where !l' = go orig x l 411 | GT | r' `ptrEq` r -> t 412 | | otherwise -> balanceR y l r' 413 | where !r' = go orig x r 414 | EQ | lazy orig `seq` (orig `ptrEq` y) -> t 415 | | otherwise -> Bin sz (lazy orig) l r 416 | 417 | -- Insert an element to the set only if it is not in the set. 418 | -- Used by `union`. 419 | 420 | -- See Note: Type of local 'go' function 421 | -- See Note: Avoiding worker/wrapper (in Data.Map.Internal) 422 | insertR :: Key -> Set -> Set 423 | insertR x0 = go x0 x0 where 424 | go :: Key -> Key -> Set -> Set 425 | go orig !_ Tip = singleton (lazy orig) 426 | go orig !x t@(Bin _ y l r) = case compare x y of 427 | LT | l' `ptrEq` l -> t 428 | | otherwise -> balanceL y l' r 429 | where !l' = go orig x l 430 | GT | r' `ptrEq` r -> t 431 | | otherwise -> balanceR y l r' 432 | where !r' = go orig x r 433 | EQ -> t 434 | 435 | -- | /O(log n)/. Delete an element from a set. 436 | 437 | -- See Note: Type of local 'go' function 438 | delete :: Key -> Set -> Set 439 | delete = go where 440 | go :: Key -> Set -> Set 441 | go !_ Tip = Tip 442 | go x t@(Bin _ y l r) = case compare x y of 443 | LT | l' `ptrEq` l -> t 444 | | otherwise -> balanceR y l' r 445 | where !l' = go x l 446 | GT | r' `ptrEq` r -> t 447 | | otherwise -> balanceL y l r' 448 | where !r' = go x r 449 | EQ -> glue l r 450 | 451 | {-------------------------------------------------------------------- 452 | Subset 453 | --------------------------------------------------------------------} 454 | -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). 455 | isProperSubsetOf :: Set -> Set -> Bool 456 | isProperSubsetOf s1 s2 = size s1 < size s2 && isSubsetOf s1 s2 457 | 458 | -- | /O(n+m)/. Is this a subset? 459 | -- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. 460 | isSubsetOf :: Set -> Set -> Bool 461 | isSubsetOf t1 t2 = size t1 <= size t2 && isSubsetOfX t1 t2 462 | 463 | isSubsetOfX :: Set -> Set -> Bool 464 | isSubsetOfX Tip _ = True 465 | isSubsetOfX _ Tip = False 466 | isSubsetOfX (Bin _ x l r) t = found && isSubsetOfX l lt && isSubsetOfX r gt where 467 | (lt,found,gt) = splitMember x t 468 | 469 | {-------------------------------------------------------------------- 470 | Minimal, Maximal 471 | --------------------------------------------------------------------} 472 | 473 | -- We perform call-pattern specialization manually on lookupMin 474 | -- and lookupMax. Otherwise, GHC doesn't seem to do it, which is 475 | -- unfortunate if, for example, someone uses findMin or findMax. 476 | 477 | lookupMinSure :: Key -> Set -> Key 478 | lookupMinSure x Tip = x 479 | lookupMinSure _ (Bin _ x l _) = lookupMinSure x l 480 | 481 | -- | /O(log n)/. The minimal element of a set. 482 | -- 483 | -- @since 0.5.9 484 | 485 | lookupMin :: Set -> Maybe Key 486 | lookupMin Tip = Nothing 487 | lookupMin (Bin _ x l _) = Just $! lookupMinSure x l 488 | 489 | -- | /O(log n)/. The minimal element of a set. 490 | findMin :: Set -> Key 491 | findMin t 492 | | Just r <- lookupMin t = r 493 | | otherwise = error "Set.findMin: empty set has no minimal element" 494 | 495 | lookupMaxSure :: Key -> Set -> Key 496 | lookupMaxSure x Tip = x 497 | lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r 498 | 499 | -- | /O(log n)/. The maximal element of a set. 500 | -- 501 | -- @since 0.5.9 502 | 503 | lookupMax :: Set -> Maybe Key 504 | lookupMax Tip = Nothing 505 | lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r 506 | 507 | -- | /O(log n)/. The maximal element of a set. 508 | findMax :: Set -> Key 509 | findMax t 510 | | Just r <- lookupMax t = r 511 | | otherwise = error "Set.findMax: empty set has no maximal element" 512 | 513 | -- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty. 514 | deleteMin :: Set -> Set 515 | deleteMin (Bin _ _ Tip r) = r 516 | deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r 517 | deleteMin Tip = Tip 518 | 519 | -- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty. 520 | deleteMax :: Set -> Set 521 | deleteMax (Bin _ _ l Tip) = l 522 | deleteMax (Bin _ x l r) = balanceL x l (deleteMax r) 523 | deleteMax Tip = Tip 524 | 525 | {-------------------------------------------------------------------- 526 | Union. 527 | --------------------------------------------------------------------} 528 | -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). 529 | unions :: [Set] -> Set 530 | unions = List.foldl' union empty 531 | 532 | -- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when 533 | -- equal elements are encountered. 534 | union :: Set -> Set -> Set 535 | union t1 Tip = t1 536 | union t1 (Bin _ x Tip Tip) = insertR x t1 537 | union (Bin _ x Tip Tip) t2 = insert x t2 538 | union Tip t2 = t2 539 | union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of 540 | (l2 :*: r2) 541 | | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1 542 | | otherwise -> link x l1l2 r1r2 543 | where !l1l2 = union l1 l2 544 | !r1r2 = union r1 r2 545 | 546 | {-------------------------------------------------------------------- 547 | Difference 548 | --------------------------------------------------------------------} 549 | -- | /O(m*log(n\/m + 1)), m <= n/. Difference of two sets. 550 | difference :: Set -> Set -> Set 551 | difference Tip _ = Tip 552 | difference t1 Tip = t1 553 | difference t1 (Bin _ x l2 r2) = case split x t1 of 554 | (l1, r1) 555 | | size l1l2 + size r1r2 == size t1 -> t1 556 | | otherwise -> merge l1l2 r1r2 557 | where !l1l2 = difference l1 l2 558 | !r1r2 = difference r1 r2 559 | 560 | {-------------------------------------------------------------------- 561 | Intersection 562 | --------------------------------------------------------------------} 563 | -- | /O(m*log(n\/m + 1)), m <= n/. The intersection of two sets. 564 | -- Keyents of the result come from the first set, so for example 565 | -- 566 | -- > import qualified Data.Set as S 567 | -- > data AB = A | B deriving Show 568 | -- > instance Ord AB where compare _ _ = EQ 569 | -- > instance Eq AB where _ == _ = True 570 | -- > main = print (S.singleton A `S.intersection` S.singleton B, 571 | -- > S.singleton B `S.intersection` S.singleton A) 572 | -- 573 | -- prints @(fromList [A],fromList [B])@. 574 | intersection :: Set -> Set -> Set 575 | intersection Tip _ = Tip 576 | intersection _ Tip = Tip 577 | intersection t1@(Bin _ x l1 r1) t2 578 | | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 579 | then t1 580 | else link x l1l2 r1r2 581 | | otherwise = merge l1l2 r1r2 582 | where 583 | !(l2, b, r2) = splitMember x t2 584 | !l1l2 = intersection l1 l2 585 | !r1r2 = intersection r1 r2 586 | 587 | {-------------------------------------------------------------------- 588 | Filter and partition 589 | --------------------------------------------------------------------} 590 | -- | /O(n)/. Filter all elements that satisfy the predicate. 591 | filter :: (Key -> Bool) -> Set -> Set 592 | filter _ Tip = Tip 593 | filter p t@(Bin _ x l r) 594 | | p x = if l `ptrEq` l' && r `ptrEq` r' 595 | then t 596 | else link x l' r' 597 | | otherwise = merge l' r' 598 | where 599 | !l' = filter p l 600 | !r' = filter p r 601 | 602 | -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy 603 | -- the predicate and one with all elements that don't satisfy the predicate. 604 | -- See also 'split'. 605 | partition :: (Key -> Bool) -> Set -> (Set,Set) 606 | partition p0 t0 = toPair $ go p0 t0 where 607 | go _ Tip = (Tip :*: Tip) 608 | go p t@(Bin _ x l r) = case (go p l, go p r) of 609 | ((l1 :*: l2), (r1 :*: r2)) 610 | | p x -> (if l1 `ptrEq` l && r1 `ptrEq` r 611 | then t 612 | else link x l1 r1) :*: merge l2 r2 613 | | otherwise -> merge l1 r1 :*: 614 | (if l2 `ptrEq` l && r2 `ptrEq` r 615 | then t 616 | else link x l2 r2) 617 | 618 | {---------------------------------------------------------------------- 619 | Map 620 | ----------------------------------------------------------------------} 621 | 622 | -- | /O(n*log n)/. 623 | -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. 624 | -- 625 | -- It's worth noting that the size of the result may be smaller if, 626 | -- for some @(x,y)@, @x \/= y && f x == f y@ 627 | 628 | map :: (Key -> Key) -> Set -> Set 629 | map f = fromList . List.map f . toList 630 | 631 | -- | /O(n)/. The 632 | -- 633 | -- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing. 634 | -- /The precondition is not checked./ 635 | -- Semi-formally, we have: 636 | -- 637 | -- > and [x < y ==> f x < f y | x <- ls, y <- ls] 638 | -- > ==> mapMonotonic f s == map f s 639 | -- > where ls = toList s 640 | 641 | mapMonotonic :: (Key -> Key) -> Set -> Set 642 | mapMonotonic _ Tip = Tip 643 | mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r) 644 | 645 | {-------------------------------------------------------------------- 646 | Fold 647 | --------------------------------------------------------------------} 648 | 649 | -- | /O(n)/. Fold the elements in the set using the given right-associative 650 | -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@. 651 | -- 652 | -- For example, 653 | -- 654 | -- > toAscList set = foldr (:) [] set 655 | foldr :: (Key -> b -> b) -> b -> Set -> b 656 | foldr f z = go z where 657 | go z' Tip = z' 658 | go z' (Bin _ x l r) = go (f x (go z' r)) l 659 | {-# inline foldr #-} 660 | 661 | -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is 662 | -- evaluated before using the result in the next application. This 663 | -- function is strict in the starting value. 664 | foldr' :: (Key -> b -> b) -> b -> Set -> b 665 | foldr' f z = go z where 666 | go !z' Tip = z' 667 | go z' (Bin _ x l r) = go (f x (go z' r)) l 668 | {-# inline foldr' #-} 669 | 670 | -- | /O(n)/. Fold the elements in the set using the given left-associative 671 | -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@. 672 | -- 673 | -- For example, 674 | -- 675 | -- > toDescList set = foldl (flip (:)) [] set 676 | foldl :: (a -> Key -> a) -> a -> Set -> a 677 | foldl f z = go z where 678 | go z' Tip = z' 679 | go z' (Bin _ x l r) = go (f (go z' l) x) r 680 | {-# inline foldl #-} 681 | 682 | -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is 683 | -- evaluated before using the result in the next application. This 684 | -- function is strict in the starting value. 685 | foldl' :: (a -> Key -> a) -> a -> Set -> a 686 | foldl' f z = go z where 687 | go !z' Tip = z' 688 | go z' (Bin _ x l r) = go (f (go z' l) x) r 689 | {-# inline foldl' #-} 690 | 691 | {-------------------------------------------------------------------- 692 | List variations 693 | --------------------------------------------------------------------} 694 | -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order. 695 | -- Subject to list fusion. 696 | elems :: Set -> [Key] 697 | elems = toAscList 698 | 699 | {-------------------------------------------------------------------- 700 | Lists 701 | --------------------------------------------------------------------} 702 | instance GHCExts.IsList Set where 703 | type Item Set = Key 704 | fromList = fromList 705 | toList = toList 706 | 707 | -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion. 708 | toList :: Set -> [Key] 709 | toList = toAscList 710 | 711 | -- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion. 712 | toAscList :: Set -> [Key] 713 | toAscList = foldr (:) [] 714 | 715 | -- | /O(n)/. Convert the set to a descending list of elements. Subject to list 716 | -- fusion. 717 | toDescList :: Set -> [Key] 718 | toDescList = foldl (flip (:)) [] 719 | 720 | -- List fusion for the list generating functions. 721 | -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion. 722 | -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude. 723 | foldrFB :: (Key -> b -> b) -> b -> Set -> b 724 | foldrFB = foldr 725 | {-# inline[0] foldrFB #-} 726 | 727 | foldlFB :: (a -> Key -> a) -> a -> Set -> a 728 | foldlFB = foldl 729 | {-# inline[0] foldlFB #-} 730 | 731 | -- Inline elems and toList, so that we need to fuse only toAscList. 732 | {-# inline elems #-} 733 | {-# inline toList #-} 734 | 735 | -- The fusion is enabled up to phase 2 included. If it does not succeed, 736 | -- convert in phase 1 the expanded to{Asc,Desc}List calls back to 737 | -- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in 738 | -- a list fusion, otherwise it would go away in phase 1), and let compiler do 739 | -- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it 740 | -- before phase 0, otherwise the fusion rules would not fire at all. 741 | {-# NOinline[0] toAscList #-} 742 | {-# NOinline[0] toDescList #-} 743 | {-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-} 744 | {-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-} 745 | {-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} 746 | {-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-} 747 | 748 | -- | /O(n*log n)/. Create a set from a list of elements. 749 | -- 750 | -- If the elements are ordered, a linear-time implementation is used, 751 | -- with the performance equal to 'fromDistinctAscList'. 752 | 753 | -- For some reason, when 'singleton' is used in fromList or in 754 | -- create, it is not inlined, so we inline it manually. 755 | fromList :: [Key] -> Set 756 | fromList [] = Tip 757 | fromList [x] = Bin 1 x Tip Tip 758 | fromList (x0 : xs0) 759 | | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0 760 | | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0 761 | where 762 | not_ordered _ [] = False 763 | not_ordered x (y : _) = x >= y 764 | {-# inline not_ordered #-} 765 | 766 | fromList' t0 xs = List.foldl' ins t0 xs where ins t x = insert x t 767 | 768 | go !_ t [] = t 769 | go _ t [x] = insertMax x t 770 | go s l xs@(x : xss) | not_ordered x xss = fromList' l xs 771 | | otherwise = case create s xss of 772 | (r, ys, []) -> go (s `shiftL` 1) (link x l r) ys 773 | (r, _, ys) -> fromList' (link x l r) ys 774 | 775 | -- The create is returning a triple (tree, xs, ys). Both xs and ys 776 | -- represent not yet processed elements and only one of them can be nonempty. 777 | -- If ys is nonempty, the keys in ys are not ordered with respect to tree 778 | -- and must be inserted using fromList'. Otherwise the keys have been 779 | -- ordered so far. 780 | create !_ [] = (Tip, [], []) 781 | create s xs@(x : xss) 782 | | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss) 783 | else (Bin 1 x Tip Tip, xss, []) 784 | | otherwise = case create (s `shiftR` 1) xs of 785 | res@(_, [], _) -> res 786 | (l, [y], zs) -> (insertMax y l, [], zs) 787 | (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys) 788 | | otherwise -> case create (s `shiftR` 1) yss of 789 | (r, zs, ws) -> (link y l r, zs, ws) 790 | 791 | {-------------------------------------------------------------------- 792 | Building trees from ascending/descending lists can be done in linear time. 793 | 794 | Note that if [xs] is ascending that: 795 | fromAscList xs == fromList xs 796 | --------------------------------------------------------------------} 797 | -- | /O(n)/. Build a set from an ascending list in linear time. 798 | -- /The precondition (input list is ascending) is not checked./ 799 | fromAscList :: [Key] -> Set 800 | fromAscList xs = fromDistinctAscList (combineEq xs) 801 | 802 | -- | /O(n)/. Build a set from a descending list in linear time. 803 | -- /The precondition (input list is descending) is not checked./ 804 | fromDescList :: [Key] -> Set 805 | fromDescList xs = fromDistinctDescList (combineEq xs) 806 | 807 | -- [combineEq xs] combines equal elements with [const] in an ordered list [xs] 808 | -- 809 | -- TODO: combineEq allocates an intermediate list. It *should* be better to 810 | -- make fromAscListBy and fromDescListBy the fundamental operations, and to 811 | -- implement the rest using those. 812 | combineEq :: [Key] -> [Key] 813 | combineEq [] = [] 814 | combineEq (x : xs) = combineEq' x xs 815 | where 816 | combineEq' z [] = [z] 817 | combineEq' z (y:ys) 818 | | z == y = combineEq' z ys 819 | | otherwise = z : combineEq' y ys 820 | 821 | -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. 822 | -- /The precondition (input list is strictly ascending) is not checked./ 823 | 824 | -- For some reason, when 'singleton' is used in fromDistinctAscList or in 825 | -- create, it is not inlined, so we inline it manually. 826 | fromDistinctAscList :: [Key] -> Set 827 | fromDistinctAscList [] = Tip 828 | fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0 829 | where 830 | go !_ t [] = t 831 | go s l (x : xs) = case create s xs of 832 | (r :*: ys) -> let !t' = link x l r 833 | in go (s `shiftL` 1) t' ys 834 | 835 | create !_ [] = (Tip :*: []) 836 | create s xs@(x : xs') 837 | | s == 1 = (Bin 1 x Tip Tip :*: xs') 838 | | otherwise = case create (s `shiftR` 1) xs of 839 | res@(_ :*: []) -> res 840 | (l :*: (y:ys)) -> case create (s `shiftR` 1) ys of 841 | (r :*: zs) -> (link y l r :*: zs) 842 | 843 | -- | /O(n)/. Build a set from a descending list of distinct elements in linear time. 844 | -- /The precondition (input list is strictly descending) is not checked./ 845 | 846 | -- For some reason, when 'singleton' is used in fromDistinctDescList or in 847 | -- create, it is not inlined, so we inline it manually. 848 | fromDistinctDescList :: [Key] -> Set 849 | fromDistinctDescList [] = Tip 850 | fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0 851 | where 852 | go !_ t [] = t 853 | go s r (x : xs) = case create s xs of 854 | (l :*: ys) -> let !t' = link x l r 855 | in go (s `shiftL` 1) t' ys 856 | 857 | create !_ [] = (Tip :*: []) 858 | create s xs@(x : xs') 859 | | s == 1 = (Bin 1 x Tip Tip :*: xs') 860 | | otherwise = case create (s `shiftR` 1) xs of 861 | res@(_ :*: []) -> res 862 | (r :*: (y:ys)) -> case create (s `shiftR` 1) ys of 863 | (l :*: zs) -> (link y l r :*: zs) 864 | 865 | {-------------------------------------------------------------------- 866 | Eq converts the set to a list. In a lazy setting, this 867 | actually seems one of the faster methods to compare two trees 868 | and it is certainly the simplest :-) 869 | --------------------------------------------------------------------} 870 | instance Eq Set where 871 | t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) 872 | 873 | {-------------------------------------------------------------------- 874 | Ord 875 | --------------------------------------------------------------------} 876 | 877 | instance Ord Set where 878 | compare s1 s2 = compare (toAscList s1) (toAscList s2) 879 | 880 | {-------------------------------------------------------------------- 881 | Show 882 | --------------------------------------------------------------------} 883 | instance Show Key => Show Set where 884 | showsPrec p xs = showParen (p > 10) $ 885 | showString "fromList " . shows (toList xs) 886 | 887 | {-------------------------------------------------------------------- 888 | Read 889 | --------------------------------------------------------------------} 890 | instance Read Key => Read Set where 891 | readPrec = parens $ prec 10 $ do 892 | Ident "fromList" <- lexP 893 | xs <- readPrec 894 | return (fromList xs) 895 | 896 | readListPrec = readListPrecDefault 897 | 898 | {-------------------------------------------------------------------- 899 | NFData 900 | --------------------------------------------------------------------} 901 | 902 | instance NFData Key => NFData Set where 903 | rnf Tip = () 904 | rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r 905 | 906 | {-------------------------------------------------------------------- 907 | Split 908 | --------------------------------------------------------------------} 909 | -- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ 910 | -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ 911 | -- comprises the elements of @set@ greater than @x@. 912 | split :: Key -> Set -> (Set,Set) 913 | split x t = toPair $ splitS x t 914 | 915 | splitS :: Key -> Set -> StrictPair Set Set 916 | splitS _ Tip = (Tip :*: Tip) 917 | splitS x (Bin _ y l r) = case compare x y of 918 | LT -> let (lt :*: gt) = splitS x l in (lt :*: link y gt r) 919 | GT -> let (lt :*: gt) = splitS x r in (link y l lt :*: gt) 920 | EQ -> (l :*: r) 921 | 922 | -- | /O(log n)/. Performs a 'split' but also returns whether the pivot 923 | -- element was found in the original set. 924 | splitMember :: Key -> Set -> (Set,Bool,Set) 925 | splitMember _ Tip = (Tip, False, Tip) 926 | splitMember x (Bin _ y l r) = case compare x y of 927 | LT -> let (lt, found, gt) = splitMember x l 928 | !gt' = link y gt r 929 | in (lt, found, gt') 930 | GT -> let (lt, found, gt) = splitMember x r 931 | !lt' = link y l lt 932 | in (lt', found, gt) 933 | EQ -> (l, True, r) 934 | 935 | {-------------------------------------------------------------------- 936 | Indexing 937 | --------------------------------------------------------------------} 938 | 939 | -- | /O(log n)/. Return the /index/ of an element, which is its zero-based 940 | -- index in the sorted sequence of elements. The index is a number from /0/ up 941 | -- to, but not including, the 'size' of the set. Calls 'error' when the element 942 | -- is not a 'member' of the set. 943 | -- 944 | -- > findIndex 2 (fromList [5,3]) Error: element is not in the set 945 | -- > findIndex 3 (fromList [5,3]) == 0 946 | -- > findIndex 5 (fromList [5,3]) == 1 947 | -- > findIndex 6 (fromList [5,3]) Error: element is not in the set 948 | 949 | -- See Note: Type of local 'go' function 950 | findIndex :: Key -> Set -> Int 951 | findIndex = go 0 where 952 | go :: Int -> Key -> Set -> Int 953 | go !_ !_ Tip = error "Set.findIndex: element is not in the set" 954 | go idx x (Bin _ kx l r) = case compare x kx of 955 | LT -> go idx x l 956 | GT -> go (idx + size l + 1) x r 957 | EQ -> idx + size l 958 | 959 | -- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based index in 960 | -- the sorted sequence of elements. The index is a number from /0/ up to, but not 961 | -- including, the 'size' of the set. 962 | -- 963 | -- > isJust (lookupIndex 2 (fromList [5,3])) == False 964 | -- > fromJust (lookupIndex 3 (fromList [5,3])) == 0 965 | -- > fromJust (lookupIndex 5 (fromList [5,3])) == 1 966 | -- > isJust (lookupIndex 6 (fromList [5,3])) == False 967 | 968 | -- See Note: Type of local 'go' function 969 | lookupIndex :: Key -> Set -> Maybe Int 970 | lookupIndex = go 0 where 971 | go :: Int -> Key -> Set -> Maybe Int 972 | go !_ !_ Tip = Nothing 973 | go idx x (Bin _ kx l r) = case compare x kx of 974 | LT -> go idx x l 975 | GT -> go (idx + size l + 1) x r 976 | EQ -> Just $! idx + size l 977 | 978 | -- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based 979 | -- index in the sorted sequence of elements. If the /index/ is out of range (less 980 | -- than zero, greater or equal to 'size' of the set), 'error' is called. 981 | -- 982 | -- > elemAt 0 (fromList [5,3]) == 3 983 | -- > elemAt 1 (fromList [5,3]) == 5 984 | -- > elemAt 2 (fromList [5,3]) Error: index out of range 985 | 986 | elemAt :: Int -> Set -> Key 987 | elemAt !_ Tip = error "Set.elemAt: index out of range" 988 | elemAt i (Bin _ x l r) = case compare i sizeL of 989 | LT -> elemAt i l 990 | GT -> elemAt (i-sizeL-1) r 991 | EQ -> x 992 | where sizeL = size l 993 | 994 | -- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in 995 | -- the sorted sequence of elements. If the /index/ is out of range (less than zero, 996 | -- greater or equal to 'size' of the set), 'error' is called. 997 | -- 998 | -- > deleteAt 0 (fromList [5,3]) == singleton 5 999 | -- > deleteAt 1 (fromList [5,3]) == singleton 3 1000 | -- > deleteAt 2 (fromList [5,3]) Error: index out of range 1001 | -- > deleteAt (-1) (fromList [5,3]) Error: index out of range 1002 | 1003 | deleteAt :: Int -> Set -> Set 1004 | deleteAt !i t = case t of 1005 | Tip -> error "Set.deleteAt: index out of range" 1006 | Bin _ x l r -> case compare i sizeL of 1007 | LT -> balanceR x (deleteAt i l) r 1008 | GT -> balanceL x l (deleteAt (i-sizeL-1) r) 1009 | EQ -> glue l r 1010 | where 1011 | sizeL = size l 1012 | 1013 | -- | Take a given number of elements in order, beginning 1014 | -- with the smallest ones. 1015 | -- 1016 | -- @ 1017 | -- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList' 1018 | -- @ 1019 | take :: Int -> Set -> Set 1020 | take i m | i >= size m = m 1021 | take i0 m0 = go i0 m0 where 1022 | go i !_ | i <= 0 = Tip 1023 | go !_ Tip = Tip 1024 | go i (Bin _ x l r) = case compare i sizeL of 1025 | LT -> go i l 1026 | GT -> link x l (go (i - sizeL - 1) r) 1027 | EQ -> l 1028 | where sizeL = size l 1029 | 1030 | -- | Drop a given number of elements in order, beginning 1031 | -- with the smallest ones. 1032 | -- 1033 | -- @ 1034 | -- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList' 1035 | -- @ 1036 | drop :: Int -> Set -> Set 1037 | drop i m | i >= size m = Tip 1038 | drop i0 m0 = go i0 m0 where 1039 | go i m | i <= 0 = m 1040 | go !_ Tip = Tip 1041 | go i (Bin _ x l r) = 1042 | case compare i sizeL of 1043 | LT -> link x (go i l) r 1044 | GT -> go (i - sizeL - 1) r 1045 | EQ -> insertMin x r 1046 | where sizeL = size l 1047 | 1048 | -- | /O(log n)/. Split a set at a particular index. 1049 | -- 1050 | -- @ 1051 | -- splitAt !n !xs = ('take' n xs, 'drop' n xs) 1052 | -- @ 1053 | splitAt :: Int -> Set -> (Set, Set) 1054 | splitAt i0 m0 1055 | | i0 >= size m0 = (m0, Tip) 1056 | | otherwise = toPair $ go i0 m0 1057 | where 1058 | go i m | i <= 0 = Tip :*: m 1059 | go !_ Tip = Tip :*: Tip 1060 | go i (Bin _ x l r) = case compare i sizeL of 1061 | LT -> case go i l of 1062 | ll :*: lr -> ll :*: link x lr r 1063 | GT -> case go (i - sizeL - 1) r of 1064 | rl :*: rr -> link x l rl :*: rr 1065 | EQ -> l :*: insertMin x r 1066 | where sizeL = size l 1067 | 1068 | -- | /O(log n)/. Take while a predicate on the elements holds. 1069 | -- The user is responsible for ensuring that for all elements @j@ and @k@ in the set, 1070 | -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. 1071 | -- 1072 | -- @ 1073 | -- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList' 1074 | -- takeWhileAntitone p = 'filter' p 1075 | -- @ 1076 | 1077 | takeWhileAntitone :: (Key -> Bool) -> Set -> Set 1078 | takeWhileAntitone _ Tip = Tip 1079 | takeWhileAntitone p (Bin _ x l r) 1080 | | p x = link x l (takeWhileAntitone p r) 1081 | | otherwise = takeWhileAntitone p l 1082 | 1083 | -- | /O(log n)/. Drop while a predicate on the elements holds. 1084 | -- The user is responsible for ensuring that for all elements @j@ and @k@ in the set, 1085 | -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. 1086 | -- 1087 | -- @ 1088 | -- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList' 1089 | -- dropWhileAntitone p = 'filter' (not . p) 1090 | -- @ 1091 | 1092 | dropWhileAntitone :: (Key -> Bool) -> Set -> Set 1093 | dropWhileAntitone _ Tip = Tip 1094 | dropWhileAntitone p (Bin _ x l r) 1095 | | p x = dropWhileAntitone p r 1096 | | otherwise = link x (dropWhileAntitone p l) r 1097 | 1098 | -- | /O(log n)/. Divide a set at the point where a predicate on the elements stops holding. 1099 | -- The user is responsible for ensuring that for all elements @j@ and @k@ in the set, 1100 | -- @j \< k ==\> p j \>= p k@. 1101 | -- 1102 | -- @ 1103 | -- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs) 1104 | -- spanAntitone p xs = partition p xs 1105 | -- @ 1106 | -- 1107 | -- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set 1108 | -- at some /unspecified/ point where the predicate switches from holding to not 1109 | -- holding (where the predicate is seen to hold before the first element and to fail 1110 | -- after the last element). 1111 | 1112 | spanAntitone :: (Key -> Bool) -> Set -> (Set, Set) 1113 | spanAntitone p0 m = toPair (go p0 m) where 1114 | go _ Tip = Tip :*: Tip 1115 | go p (Bin _ x l r) 1116 | | p x = let u :*: v = go p r in link x l u :*: v 1117 | | otherwise = let u :*: v = go p l in u :*: link x v r 1118 | 1119 | 1120 | {-------------------------------------------------------------------- 1121 | Utility functions that maintain the balance properties of the tree. 1122 | All constructors assume that all values in [l] < [x] and all values 1123 | in [r] > [x], and that [l] and [r] are valid trees. 1124 | 1125 | In order of sophistication: 1126 | [Bin sz x l r] The type constructor. 1127 | [bin x l r] Maintains the correct size, assumes that both [l] 1128 | and [r] are balanced with respect to each other. 1129 | [balance x l r] Restores the balance and size. 1130 | Assumes that the original tree was balanced and 1131 | that [l] or [r] has changed by at most one element. 1132 | [link x l r] Restores balance and size. 1133 | 1134 | Furthermore, we can construct a new tree from two trees. Both operations 1135 | assume that all values in [l] < all values in [r] and that [l] and [r] 1136 | are valid: 1137 | [glue l r] Glues [l] and [r] together. Assumes that [l] and 1138 | [r] are already balanced with respect to each other. 1139 | [merge l r] Merges two trees and restores balance. 1140 | --------------------------------------------------------------------} 1141 | 1142 | {-------------------------------------------------------------------- 1143 | Link 1144 | --------------------------------------------------------------------} 1145 | link :: Key -> Set -> Set -> Set 1146 | link x Tip r = insertMin x r 1147 | link x l Tip = insertMax x l 1148 | link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz) 1149 | | delta*sizeL < sizeR = balanceL z (link x l lz) rz 1150 | | delta*sizeR < sizeL = balanceR y ly (link x ry r) 1151 | | otherwise = bin x l r 1152 | 1153 | -- insertMin and insertMax don't perform potentially expensive comparisons. 1154 | insertMax,insertMin :: Key -> Set -> Set 1155 | insertMax x t = case t of 1156 | Tip -> singleton x 1157 | Bin _ y l r -> balanceR y l (insertMax x r) 1158 | 1159 | insertMin x t = case t of 1160 | Tip -> singleton x 1161 | Bin _ y l r -> balanceL y (insertMin x l) r 1162 | 1163 | {-------------------------------------------------------------------- 1164 | [merge l r]: merges two trees. 1165 | --------------------------------------------------------------------} 1166 | merge :: Set -> Set -> Set 1167 | merge Tip r = r 1168 | merge l Tip = l 1169 | merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry) 1170 | | delta*sizeL < sizeR = balanceL y (merge l ly) ry 1171 | | delta*sizeR < sizeL = balanceR x lx (merge rx r) 1172 | | otherwise = glue l r 1173 | 1174 | {-------------------------------------------------------------------- 1175 | [glue l r]: glues two trees together. 1176 | Assumes that [l] and [r] are already balanced with respect to each other. 1177 | --------------------------------------------------------------------} 1178 | glue :: Set -> Set -> Set 1179 | glue Tip r = r 1180 | glue l Tip = l 1181 | glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr) 1182 | | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r 1183 | | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r' 1184 | 1185 | -- | /O(log n)/. Delete and find the minimal element. 1186 | -- 1187 | -- > deleteFindMin set = (findMin set, deleteMin set) 1188 | 1189 | deleteFindMin :: Set -> (Key, Set) 1190 | deleteFindMin t 1191 | | Just r <- minView t = r 1192 | | otherwise = (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip) 1193 | 1194 | -- | /O(log n)/. Delete and find the maximal element. 1195 | -- 1196 | -- > deleteFindMax set = (findMax set, deleteMax set) 1197 | deleteFindMax :: Set -> (Key, Set) 1198 | deleteFindMax t 1199 | | Just r <- maxView t = r 1200 | | otherwise = (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip) 1201 | 1202 | minViewSure :: Key -> Set -> Set -> StrictPair Key Set 1203 | minViewSure = go where 1204 | go x Tip r = x :*: r 1205 | go x (Bin _ xl ll lr) r = case go xl ll lr of 1206 | xm :*: l' -> xm :*: balanceR x l' r 1207 | 1208 | -- | /O(log n)/. Retrieves the minimal key of the set, and the set 1209 | -- stripped of that element, or 'Nothing' if passed an empty set. 1210 | minView :: Set -> Maybe (Key, Set) 1211 | minView Tip = Nothing 1212 | minView (Bin _ x l r) = Just $! toPair $ minViewSure x l r 1213 | 1214 | maxViewSure :: Key -> Set -> Set -> StrictPair Key Set 1215 | maxViewSure = go where 1216 | go x l Tip = x :*: l 1217 | go x l (Bin _ xr rl rr) = case go xr rl rr of 1218 | xm :*: r' -> xm :*: balanceL x l r' 1219 | 1220 | -- | /O(log n)/. Retrieves the maximal key of the set, and the set 1221 | -- stripped of that element, or 'Nothing' if passed an empty set. 1222 | maxView :: Set -> Maybe (Key, Set) 1223 | maxView Tip = Nothing 1224 | maxView (Bin _ x l r) = Just $! toPair $ maxViewSure x l r 1225 | 1226 | {-------------------------------------------------------------------- 1227 | [balance x l r] balances two trees with value x. 1228 | The sizes of the trees should balance after decreasing the 1229 | size of one of them. (a rotation). 1230 | 1231 | [delta] is the maximal relative difference between the sizes of 1232 | two trees, it corresponds with the [w] in Adams' paper. 1233 | [ratio] is the ratio between an outer and inner sibling of the 1234 | heavier subtree in an unbalanced setting. It determines 1235 | whether a double or single rotation should be performed 1236 | to restore balance. It is correspondes with the inverse 1237 | of $\alpha$ in Adam's article. 1238 | 1239 | Note that according to the Adam's paper: 1240 | - [delta] should be larger than 4.646 with a [ratio] of 2. 1241 | - [delta] should be larger than 3.745 with a [ratio] of 1.534. 1242 | 1243 | But the Adam's paper is errorneous: 1244 | - it can be proved that for delta=2 and delta>=5 there does 1245 | not exist any ratio that would work 1246 | - delta=4.5 and ratio=2 does not work 1247 | 1248 | That leaves two reasonable variants, delta=3 and delta=4, 1249 | both with ratio=2. 1250 | 1251 | - A lower [delta] leads to a more 'perfectly' balanced tree. 1252 | - A higher [delta] performs less rebalancing. 1253 | 1254 | In the benchmarks, delta=3 is faster on insert operations, 1255 | and delta=4 has slightly better deletes. As the insert speedup 1256 | is larger, we currently use delta=3. 1257 | 1258 | --------------------------------------------------------------------} 1259 | delta,ratio :: Int 1260 | delta = 3 1261 | ratio = 2 1262 | 1263 | -- The balance function is equivalent to the following: 1264 | -- 1265 | -- balance :: a -> Set a -> Set a -> Set a 1266 | -- balance x l r 1267 | -- | sizeL + sizeR <= 1 = Bin sizeX x l r 1268 | -- | sizeR > delta*sizeL = rotateL x l r 1269 | -- | sizeL > delta*sizeR = rotateR x l r 1270 | -- | otherwise = Bin sizeX x l r 1271 | -- where 1272 | -- sizeL = size l 1273 | -- sizeR = size r 1274 | -- sizeX = sizeL + sizeR + 1 1275 | -- 1276 | -- rotateL :: a -> Set a -> Set a -> Set a 1277 | -- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r 1278 | -- | otherwise = doubleL x l r 1279 | -- rotateR :: a -> Set a -> Set a -> Set a 1280 | -- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r 1281 | -- | otherwise = doubleR x l r 1282 | -- 1283 | -- singleL, singleR :: a -> Set a -> Set a -> Set a 1284 | -- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3 1285 | -- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3) 1286 | -- 1287 | -- doubleL, doubleR :: a -> Set a -> Set a -> Set a 1288 | -- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4) 1289 | -- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4) 1290 | -- 1291 | -- It is only written in such a way that every node is pattern-matched only once. 1292 | -- 1293 | -- Only balanceL and balanceR are needed at the moment, so balance is not here anymore. 1294 | -- In case it is needed, it can be found in Data.Map. 1295 | 1296 | -- Functions balanceL and balanceR are specialised versions of balance. 1297 | -- balanceL only checks whether the left subtree is too big, 1298 | -- balanceR only checks whether the right subtree is too big. 1299 | 1300 | -- balanceL is called when left subtree might have been inserted to or when 1301 | -- right subtree might have been deleted from. 1302 | 1303 | balanceL :: Key -> Set -> Set -> Set 1304 | balanceL x l r = case r of 1305 | Tip -> case l of 1306 | Tip -> Bin 1 x Tip Tip 1307 | Bin _ _ Tip Tip -> Bin 2 x l Tip 1308 | Bin _ lx Tip (Bin _ lrx _ _) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip) 1309 | Bin _ lx ll@(Bin _ _ _ _) Tip -> Bin 3 lx ll (Bin 1 x Tip Tip) 1310 | Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr) 1311 | | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip) 1312 | | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip) 1313 | 1314 | Bin rs _ _ _ -> case l of 1315 | Tip -> Bin (1+rs) x Tip r 1316 | 1317 | Bin ls lx ll lr 1318 | | ls > delta*rs -> case (ll, lr) of 1319 | (Bin lls _ _ _, Bin lrs lrx lrl lrr) 1320 | | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r) 1321 | | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r) 1322 | (_, _) -> error "Failure in Data.Map.balanceL" 1323 | | otherwise -> Bin (1+ls+rs) x l r 1324 | {-# noinline balanceL #-} 1325 | 1326 | -- balanceR is called when right subtree might have been inserted to or when 1327 | -- left subtree might have been deleted from. 1328 | balanceR :: Key -> Set -> Set -> Set 1329 | balanceR x l r = case l of 1330 | Tip -> case r of 1331 | Tip -> Bin 1 x Tip Tip 1332 | Bin _ _ Tip Tip -> Bin 2 x Tip r 1333 | Bin _ rx Tip rr@(Bin _ _ _ _) -> Bin 3 rx (Bin 1 x Tip Tip) rr 1334 | Bin _ rx (Bin _ rlx _ _) Tip -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip) 1335 | Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _) 1336 | | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr 1337 | | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr) 1338 | 1339 | Bin ls _ _ _ -> case r of 1340 | Tip -> Bin (1+ls) x l Tip 1341 | 1342 | Bin rs rx rl rr 1343 | | rs > delta*ls -> case (rl, rr) of 1344 | (Bin rls rlx rll rlr, Bin rrs _ _ _) 1345 | | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr 1346 | | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr) 1347 | (_, _) -> error "Failure in Data.Map.balanceR" 1348 | | otherwise -> Bin (1+ls+rs) x l r 1349 | {-# noinline balanceR #-} 1350 | 1351 | {-------------------------------------------------------------------- 1352 | The bin constructor maintains the size of the tree 1353 | --------------------------------------------------------------------} 1354 | bin :: Key -> Set -> Set -> Set 1355 | bin x l r 1356 | = Bin (size l + size r + 1) x l r 1357 | {-# inline bin #-} 1358 | 1359 | {-------------------------------------------------------------------- 1360 | Utilities 1361 | --------------------------------------------------------------------} 1362 | 1363 | -- | /O(1)/. Decompose a set into pieces based on the structure of the underlying 1364 | -- tree. This function is useful for consuming a set in parallel. 1365 | -- 1366 | -- No guarantee is made as to the sizes of the pieces; an internal, but 1367 | -- deterministic process determines this. However, it is guaranteed that the pieces 1368 | -- returned will be in ascending order (all elements in the first subset less than all 1369 | -- elements in the second, and so on). 1370 | -- 1371 | -- Examples: 1372 | -- 1373 | -- > splitRoot (fromList [1..6]) == 1374 | -- > [fromList [1,2,3],fromList [4],fromList [5,6]] 1375 | -- 1376 | -- > splitRoot empty == [] 1377 | -- 1378 | -- Note that the current implementation does not return more than three subsets, 1379 | -- but you should not depend on this behaviour because it can change in the 1380 | -- future without notice. 1381 | splitRoot :: Set -> [Set] 1382 | splitRoot orig = case orig of 1383 | Tip -> [] 1384 | Bin _ v l r -> [l, singleton v, r] 1385 | {-# inline splitRoot #-} 1386 | 1387 | {-------------------------------------------------------------------- 1388 | Debugging 1389 | --------------------------------------------------------------------} 1390 | -- | /O(n)/. Show the tree that implements the set. The tree is shown 1391 | -- in a compressed, hanging format. 1392 | showTree :: Show Key => Set -> String 1393 | showTree s = showTreeWith True False s 1394 | 1395 | 1396 | {- | /O(n)/. The expression (@showTreeWith hang wide map@) shows 1397 | the tree that implements the set. If @hang@ is 1398 | @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If 1399 | @wide@ is 'True', an extra wide version is shown. 1400 | 1401 | > Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5] 1402 | > 4 1403 | > +--2 1404 | > | +--1 1405 | > | +--3 1406 | > +--5 1407 | > 1408 | > Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5] 1409 | > 4 1410 | > | 1411 | > +--2 1412 | > | | 1413 | > | +--1 1414 | > | | 1415 | > | +--3 1416 | > | 1417 | > +--5 1418 | > 1419 | > Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5] 1420 | > +--5 1421 | > | 1422 | > 4 1423 | > | 1424 | > | +--3 1425 | > | | 1426 | > +--2 1427 | > | 1428 | > +--1 1429 | 1430 | -} 1431 | showTreeWith :: Show Key => Bool -> Bool -> Set -> String 1432 | showTreeWith hang wide t 1433 | | hang = (showsTreeHang wide [] t) "" 1434 | | otherwise = (showsTree wide [] [] t) "" 1435 | 1436 | showsTree :: Show Key => Bool -> [String] -> [String] -> Set -> ShowS 1437 | showsTree wide lbars rbars t = case t of 1438 | Tip -> showsBars lbars . showString "|\n" 1439 | Bin _ x Tip Tip -> showsBars lbars . shows x . showString "\n" 1440 | Bin _ x l r -> 1441 | showsTree wide (withBar rbars) (withEmpty rbars) r . 1442 | showWide wide rbars . 1443 | showsBars lbars . shows x . showString "\n" . 1444 | showWide wide lbars . 1445 | showsTree wide (withEmpty lbars) (withBar lbars) l 1446 | 1447 | showsTreeHang :: Show Key => Bool -> [String] -> Set -> ShowS 1448 | showsTreeHang wide bars t = case t of 1449 | Tip -> showsBars bars . showString "|\n" 1450 | Bin _ x Tip Tip -> showsBars bars . shows x . showString "\n" 1451 | Bin _ x l r -> 1452 | showsBars bars . shows x . showString "\n" . 1453 | showWide wide bars . 1454 | showsTreeHang wide (withBar bars) l . 1455 | showWide wide bars . 1456 | showsTreeHang wide (withEmpty bars) r 1457 | 1458 | showWide :: Bool -> [String] -> String -> String 1459 | showWide wide bars 1460 | | wide = showString (concat (reverse bars)) . showString "|\n" 1461 | | otherwise = id 1462 | 1463 | showsBars :: [String] -> ShowS 1464 | showsBars bars 1465 | = case bars of 1466 | [] -> id 1467 | _ -> showString (concat (reverse (tail bars))) . showString node 1468 | 1469 | node :: String 1470 | node = "+--" 1471 | 1472 | withBar, withEmpty :: [String] -> [String] 1473 | withBar bars = "| ":bars 1474 | withEmpty bars = " ":bars 1475 | 1476 | {-------------------------------------------------------------------- 1477 | Assertions 1478 | --------------------------------------------------------------------} 1479 | -- | /O(n)/. Test if the internal set structure is valid. 1480 | valid :: Set -> Bool 1481 | valid t = balanced t && ordered t && validsize t 1482 | 1483 | ordered :: Set -> Bool 1484 | ordered t = bounded (const True) (const True) t where 1485 | bounded lo hi t' = case t' of 1486 | Tip -> True 1487 | Bin _ x l r -> (lo x) && (hi x) && bounded lo (x) hi r 1488 | 1489 | balanced :: Set -> Bool 1490 | balanced t = case t of 1491 | Tip -> True 1492 | Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && 1493 | balanced l && balanced r 1494 | 1495 | validsize :: Set -> Bool 1496 | validsize t = realsize t == Just (size t) where 1497 | realsize t' = case t' of 1498 | Tip -> Just 0 1499 | Bin sz _ l r -> case (realsize l,realsize r) of 1500 | (Just n, Just m) | n+m+1 == sz -> Just sz 1501 | _ -> Nothing 1502 | -------------------------------------------------------------------------------- /unpacked-containers/unpacked-containers.cabal: -------------------------------------------------------------------------------- 1 | name: unpacked-containers 2 | category: Language 3 | version: 0 4 | license: BSD2 5 | license-file: LICENSE 6 | cabal-version: 2.0 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: experimental 10 | homepage: http://github.com/ekmett/unpacked-containers/ 11 | bug-reports: http://github.com/ekmett/unpacked-containers/issues 12 | copyright: Copyright (C) 2017-2018 Edward A. Kmett 13 | build-type: Simple 14 | synopsis: Unpacked containers via backpack 15 | description: This backpack mixin package supplies unpacked sets and maps exploiting backpack's ability to unpack through signatures. 16 | extra-source-files: 17 | README.md 18 | CHANGELOG.md 19 | LICENSE 20 | include/containers.h 21 | 22 | source-repository head 23 | type: git 24 | location: git://github.com/ekmett/unpacked-containers.git 25 | 26 | library 27 | default-language: Haskell2010 28 | ghc-options: -Wall -O2 29 | hs-source-dirs: src 30 | signatures: 31 | Key 32 | 33 | exposed-modules: 34 | Map 35 | Map.Internal 36 | Map.Internal.Debug 37 | Map.Lazy 38 | Map.Merge.Lazy 39 | Map.Merge.Strict 40 | Map.Strict 41 | Map.Strict.Internal 42 | Set 43 | Set.Internal 44 | 45 | build-depends: 46 | base >= 4.10 && < 5, 47 | data-default-class ^>= 0.1, 48 | deepseq ^>= 1.4, 49 | utils 50 | 51 | -- separate internal library to avoid recompiling these all the time 52 | library utils 53 | default-language: Haskell2010 54 | hs-source-dirs: utils 55 | include-dirs: include 56 | ghc-options: -Wall -O2 57 | 58 | build-depends: 59 | base >= 4.10 && < 5, 60 | deepseq >= 1.2 && < 1.5, 61 | ghc-prim 62 | 63 | exposed-modules: 64 | Internal.BitUtil 65 | Internal.BitQueue 66 | Internal.State 67 | Internal.StrictPair 68 | Internal.StrictFold 69 | Internal.StrictMaybe 70 | Internal.PtrEquality 71 | 72 | -- we have to provide a module in another library that matches the signature 73 | library example 74 | default-language: Haskell2010 75 | hs-source-dirs: example 76 | exposed-modules: Int 77 | build-depends: base 78 | 79 | executable unpacked-set-example 80 | default-language: Haskell2010 81 | main-is: example/Main.hs 82 | build-depends: base, unpacked-containers, example 83 | mixins: unpacked-containers (Set as Int.Set) requires (Key as Int) 84 | -------------------------------------------------------------------------------- /unpacked-containers/utils/Internal/BitQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | #include "containers.h" 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Internal.BitQueue 9 | -- Copyright : (c) David Feuer 2016 10 | -- License : BSD-style 11 | -- Maintainer : libraries@haskell.org 12 | -- Portability : portable 13 | -- 14 | -- = WARNING 15 | -- 16 | -- This module is considered __internal__. 17 | -- 18 | -- The Package Versioning Policy __does not apply__. 19 | -- 20 | -- This contents of this module may change __in any way whatsoever__ 21 | -- and __without any warning__ between minor versions of this package. 22 | -- 23 | -- Authors importing this module are expected to track development 24 | -- closely. 25 | -- 26 | -- = Description 27 | -- 28 | -- An extremely light-weight, fast, and limited representation of a string of 29 | -- up to (2*WORDSIZE - 2) bits. In fact, there are two representations, 30 | -- misleadingly named bit queue builder and bit queue. The builder supports 31 | -- only `emptyQB`, creating an empty builder, and `snocQB`, enqueueing a bit. 32 | -- The bit queue builder is then turned into a bit queue using `buildQ`, after 33 | -- which bits can be removed one by one using `unconsQ`. If the size limit is 34 | -- exceeded, further operations will silently produce nonsense. 35 | ----------------------------------------------------------------------------- 36 | 37 | module Internal.BitQueue 38 | ( BitQueue 39 | , BitQueueB 40 | , emptyQB 41 | , snocQB 42 | , buildQ 43 | , unconsQ 44 | , toListQ 45 | ) where 46 | 47 | #if !MIN_VERSION_base(4,8,0) 48 | import Data.Word (Word) 49 | #endif 50 | import Internal.BitUtil (shiftLL, shiftRL, wordSize) 51 | import Data.Bits ((.|.), (.&.), testBit) 52 | #if MIN_VERSION_base(4,8,0) 53 | import Data.Bits (countTrailingZeros) 54 | #elif MIN_VERSION_base(4,5,0) 55 | import Data.Bits (popCount) 56 | #endif 57 | 58 | #if !MIN_VERSION_base(4,5,0) 59 | -- We could almost certainly improve this fall-back (copied straight from the 60 | -- default definition in Data.Bits), but it hardly seems worth the trouble 61 | -- to speed things up on GHC 7.4 and below. 62 | countTrailingZeros :: Word -> Int 63 | countTrailingZeros x = go 0 64 | where 65 | go i | i >= wordSize = i 66 | | testBit x i = i 67 | | otherwise = go (i+1) 68 | 69 | #elif !MIN_VERSION_base(4,8,0) 70 | countTrailingZeros :: Word -> Int 71 | countTrailingZeros x = popCount ((x .&. (-x)) - 1) 72 | {-# INLINE countTrailingZeros #-} 73 | #endif 74 | 75 | -- A bit queue builder. We represent a double word using two words 76 | -- because we don't currently have access to proper double words. 77 | data BitQueueB = BQB {-# UNPACK #-} !Word 78 | {-# UNPACK #-} !Word 79 | 80 | newtype BitQueue = BQ BitQueueB deriving Show 81 | 82 | -- Intended for debugging. 83 | instance Show BitQueueB where 84 | show (BQB hi lo) = "BQ"++ 85 | show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0] 86 | ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0]) 87 | 88 | -- | Create an empty bit queue builder. This is represented as a single guard 89 | -- bit in the most significant position. 90 | emptyQB :: BitQueueB 91 | emptyQB = BQB (1 `shiftLL` (wordSize - 1)) 0 92 | {-# INLINE emptyQB #-} 93 | 94 | -- Shift the double word to the right by one bit. 95 | shiftQBR1 :: BitQueueB -> BitQueueB 96 | shiftQBR1 (BQB hi lo) = BQB hi' lo' where 97 | lo' = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1)) 98 | hi' = hi `shiftRL` 1 99 | {-# INLINE shiftQBR1 #-} 100 | 101 | -- | Enqueue a bit. This works by shifting the queue right one bit, 102 | -- then setting the most significant bit as requested. 103 | {-# INLINE snocQB #-} 104 | snocQB :: BitQueueB -> Bool -> BitQueueB 105 | snocQB bq b = case shiftQBR1 bq of 106 | BQB hi lo -> BQB (hi .|. (fromIntegral (fromEnum b) `shiftLL` (wordSize - 1))) lo 107 | 108 | -- | Convert a bit queue builder to a bit queue. This shifts in a new 109 | -- guard bit on the left, and shifts right until the old guard bit falls 110 | -- off. 111 | {-# INLINE buildQ #-} 112 | buildQ :: BitQueueB -> BitQueue 113 | buildQ (BQB hi 0) = BQ (BQB 0 lo') where 114 | zeros = countTrailingZeros hi 115 | lo' = ((hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))) `shiftRL` zeros 116 | buildQ (BQB hi lo) = BQ (BQB hi' lo') where 117 | zeros = countTrailingZeros lo 118 | lo1 = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1)) 119 | hi1 = (hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1)) 120 | lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros)) 121 | hi' = hi1 `shiftRL` zeros 122 | 123 | -- Test if the queue is empty, which occurs when theres 124 | -- nothing left but a guard bit in the least significant 125 | -- place. 126 | nullQ :: BitQueue -> Bool 127 | nullQ (BQ (BQB 0 1)) = True 128 | nullQ _ = False 129 | {-# INLINE nullQ #-} 130 | 131 | -- | Dequeue an element, or discover the queue is empty. 132 | unconsQ :: BitQueue -> Maybe (Bool, BitQueue) 133 | unconsQ q | nullQ q = Nothing 134 | unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl) 135 | where 136 | !hd = (lo .&. 1) /= 0 137 | !tl = shiftQBR1 bq 138 | {-# INLINE unconsQ #-} 139 | 140 | -- | Convert a bit queue to a list of bits by unconsing. 141 | -- This is used to test that the queue functions properly. 142 | toListQ :: BitQueue -> [Bool] 143 | toListQ bq = case unconsQ bq of 144 | Nothing -> [] 145 | Just (hd, tl) -> hd : toListQ tl 146 | -------------------------------------------------------------------------------- /unpacked-containers/utils/Internal/BitUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ 3 | {-# LANGUAGE MagicHash #-} 4 | #endif 5 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 6 | {-# LANGUAGE Safe #-} 7 | #endif 8 | 9 | #include "containers.h" 10 | 11 | ----------------------------------------------------------------------------- 12 | -- | 13 | -- Module : Internal.BitUtil 14 | -- Copyright : (c) Clark Gaebel 2012 15 | -- (c) Johan Tibel 2012 16 | -- License : BSD-style 17 | -- Maintainer : libraries@haskell.org 18 | -- Portability : portable 19 | ----------------------------------------------------------------------------- 20 | -- 21 | -- = WARNING 22 | -- 23 | -- This module is considered __internal__. 24 | -- 25 | -- The Package Versioning Policy __does not apply__. 26 | -- 27 | -- This contents of this module may change __in any way whatsoever__ 28 | -- and __without any warning__ between minor versions of this package. 29 | -- 30 | -- Authors importing this module are expected to track development 31 | -- closely. 32 | 33 | module Internal.BitUtil 34 | ( bitcount 35 | , highestBitMask 36 | , shiftLL 37 | , shiftRL 38 | , wordSize 39 | ) where 40 | 41 | import Data.Bits ((.|.), xor) 42 | #if MIN_VERSION_base(4,5,0) 43 | import Data.Bits (popCount, unsafeShiftL, unsafeShiftR) 44 | #else 45 | import Data.Bits ((.&.), shiftL, shiftR) 46 | #endif 47 | #if MIN_VERSION_base(4,7,0) 48 | import Data.Bits (finiteBitSize) 49 | #else 50 | import Data.Bits (bitSize) 51 | #endif 52 | 53 | #if !MIN_VERSION_base (4,8,0) 54 | import Data.Word (Word) 55 | #endif 56 | 57 | {---------------------------------------------------------------------- 58 | [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006, 59 | based on the code on 60 | http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan, 61 | where the following source is given: 62 | Published in 1988, the C Programming Language 2nd Ed. (by Brian W. 63 | Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April 64 | 19, 2006 Don Knuth pointed out to me that this method "was first published 65 | by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by 66 | Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)" 67 | ----------------------------------------------------------------------} 68 | 69 | bitcount :: Int -> Word -> Int 70 | #if MIN_VERSION_base(4,5,0) 71 | bitcount a x = a + popCount x 72 | #else 73 | bitcount a0 x0 = go a0 x0 74 | where go a 0 = a 75 | go a x = go (a + 1) (x .&. (x-1)) 76 | #endif 77 | {-# INLINE bitcount #-} 78 | 79 | -- The highestBitMask implementation is based on 80 | -- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 81 | -- which has been put in the public domain. 82 | 83 | -- | Return a word where only the highest bit is set. 84 | highestBitMask :: Word -> Word 85 | highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1 86 | x3 = x2 .|. x2 `shiftRL` 2 87 | x4 = x3 .|. x3 `shiftRL` 4 88 | x5 = x4 .|. x4 `shiftRL` 8 89 | x6 = x5 .|. x5 `shiftRL` 16 90 | #if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32) 91 | x7 = x6 .|. x6 `shiftRL` 32 92 | in x7 `xor` (x7 `shiftRL` 1) 93 | #else 94 | in x6 `xor` (x6 `shiftRL` 1) 95 | #endif 96 | {-# INLINE highestBitMask #-} 97 | 98 | -- Right and left logical shifts. 99 | shiftRL, shiftLL :: Word -> Int -> Word 100 | #if MIN_VERSION_base(4,5,0) 101 | shiftRL = unsafeShiftR 102 | shiftLL = unsafeShiftL 103 | #else 104 | shiftRL = shiftR 105 | shiftLL = shiftL 106 | #endif 107 | 108 | {-# INLINE wordSize #-} 109 | wordSize :: Int 110 | #if MIN_VERSION_base(4,7,0) 111 | wordSize = finiteBitSize (0 :: Word) 112 | #else 113 | wordSize = bitSize (0 :: Word) 114 | #endif 115 | -------------------------------------------------------------------------------- /unpacked-containers/utils/Internal/PtrEquality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifdef __GLASGOW_HASKELL__ 3 | {-# LANGUAGE MagicHash #-} 4 | #endif 5 | 6 | {-# OPTIONS_HADDOCK hide #-} 7 | 8 | -- | Really unsafe pointer equality 9 | module Internal.PtrEquality (ptrEq, hetPtrEq) where 10 | 11 | #ifdef __GLASGOW_HASKELL__ 12 | import GHC.Exts ( reallyUnsafePtrEquality# ) 13 | import Unsafe.Coerce ( unsafeCoerce ) 14 | #if __GLASGOW_HASKELL__ < 707 15 | import GHC.Exts ( (==#) ) 16 | #else 17 | import GHC.Exts ( isTrue# ) 18 | #endif 19 | #endif 20 | 21 | -- | Checks if two pointers are equal. Yes means yes; 22 | -- no means maybe. The values should be forced to at least 23 | -- WHNF before comparison to get moderately reliable results. 24 | ptrEq :: a -> a -> Bool 25 | 26 | -- | Checks if two pointers are equal, without requiring 27 | -- them to have the same type. The values should be forced 28 | -- to at least WHNF before comparison to get moderately 29 | -- reliable results. 30 | hetPtrEq :: a -> b -> Bool 31 | 32 | #ifdef __GLASGOW_HASKELL__ 33 | #if __GLASGOW_HASKELL__ < 707 34 | ptrEq x y = reallyUnsafePtrEquality# x y ==# 1# 35 | hetPtrEq x y = unsafeCoerce reallyUnsafePtrEquality# x y ==# 1# 36 | #else 37 | ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y) 38 | hetPtrEq x y = isTrue# (unsafeCoerce reallyUnsafePtrEquality# x y) 39 | #endif 40 | 41 | #else 42 | -- Not GHC 43 | ptrEq _ _ = False 44 | hetPtrEq _ _ = False 45 | #endif 46 | 47 | {-# INLINE ptrEq #-} 48 | {-# INLINE hetPtrEq #-} 49 | 50 | infix 4 `ptrEq` 51 | infix 4 `hetPtrEq` 52 | -------------------------------------------------------------------------------- /unpacked-containers/utils/Internal/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #include "containers.h" 3 | {-# OPTIONS_HADDOCK hide #-} 4 | 5 | -- | A clone of Control.Monad.State.Strict. 6 | module Internal.State where 7 | 8 | import Prelude hiding ( 9 | #if MIN_VERSION_base(4,8,0) 10 | Applicative 11 | #endif 12 | ) 13 | 14 | import Control.Monad (ap) 15 | import Control.Applicative (Applicative(..), liftA) 16 | 17 | newtype State s a = State {runState :: s -> (s, a)} 18 | 19 | instance Functor (State s) where 20 | fmap = liftA 21 | 22 | instance Monad (State s) where 23 | {-# INLINE return #-} 24 | {-# INLINE (>>=) #-} 25 | return = pure 26 | m >>= k = State $ \ s -> case runState m s of 27 | (s', x) -> runState (k x) s' 28 | 29 | instance Applicative (State s) where 30 | {-# INLINE pure #-} 31 | pure x = State $ \ s -> (s, x) 32 | (<*>) = ap 33 | 34 | execState :: State s a -> s -> a 35 | execState m x = snd (runState m x) 36 | -------------------------------------------------------------------------------- /unpacked-containers/utils/Internal/StrictFold.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | #include "containers.h" 7 | {-# OPTIONS_HADDOCK hide #-} 8 | 9 | module Internal.StrictFold (foldlStrict) where 10 | 11 | -- | Same as regular 'Data.List.foldl'', but marked INLINE so that it is always 12 | -- inlined. This allows further optimization of the call to f, which can be 13 | -- optimized/specialised/inlined. 14 | 15 | foldlStrict :: (a -> b -> a) -> a -> [b] -> a 16 | foldlStrict f = go 17 | where 18 | go z [] = z 19 | go z (x:xs) = let z' = f z x in z' `seq` go z' xs 20 | {-# INLINE foldlStrict #-} 21 | -------------------------------------------------------------------------------- /unpacked-containers/utils/Internal/StrictMaybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #include "containers.h" 4 | 5 | {-# OPTIONS_HADDOCK hide #-} 6 | -- | Strict 'Maybe' 7 | 8 | module Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where 9 | 10 | #if !MIN_VERSION_base(4,8,0) 11 | import Data.Foldable (Foldable (..)) 12 | import Data.Monoid (Monoid (..)) 13 | #endif 14 | 15 | data MaybeS a = NothingS | JustS !a 16 | 17 | instance Foldable MaybeS where 18 | foldMap _ NothingS = mempty 19 | foldMap f (JustS a) = f a 20 | 21 | maybeS :: r -> (a -> r) -> MaybeS a -> r 22 | maybeS n _ NothingS = n 23 | maybeS _ j (JustS a) = j a 24 | 25 | toMaybe :: MaybeS a -> Maybe a 26 | toMaybe NothingS = Nothing 27 | toMaybe (JustS a) = Just a 28 | 29 | toMaybeS :: Maybe a -> MaybeS a 30 | toMaybeS Nothing = NothingS 31 | toMaybeS (Just a) = JustS a 32 | -------------------------------------------------------------------------------- /unpacked-containers/utils/Internal/StrictPair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | #include "containers.h" 7 | 8 | -- | A strict pair 9 | 10 | module Internal.StrictPair (StrictPair(..), toPair) where 11 | 12 | -- | The same as a regular Haskell pair, but 13 | -- 14 | -- @ 15 | -- (x :*: _|_) = (_|_ :*: y) = _|_ 16 | -- @ 17 | data StrictPair a b = !a :*: !b 18 | 19 | infixr 1 :*: 20 | 21 | -- | Convert a strict pair to a standard pair. 22 | toPair :: StrictPair a b -> (a, b) 23 | toPair (x :*: y) = (x, y) 24 | {-# INLINE toPair #-} 25 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0 2 | 3 | * repository initialized 4 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2018, Edward Kmett 2 | (c) 2002 Daan Leijen 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are 8 | met: 9 | 10 | * Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. 17 | 18 | * Neither the name of Edward Kmett nor the names of other 19 | contributors may be used to endorse or promote products derived 20 | from this software without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 30 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 31 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 32 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/README.md: -------------------------------------------------------------------------------- 1 | unpacked-containers 2 | == 3 | 4 | This package supplies a simple unpacked version of `Data.Set` and `Data.Map` using backpack. 5 | 6 | This can remove a level of indirection on the heap and unpack your keys directly into nodes of your sets and maps. 7 | 8 | The exported modules roughly follow the API of `containers 0.5.11`, but with all deprecated functions removed. 9 | 10 | Note however, that all CPP has been removed relative to `containers`, because on one hand, use of backpack locks us to a current version of GHC, 11 | and on the other there is a bug in GHC 8.2.2 that prevents the use of CPP in a module that uses backpack. This issue is resolved in GHC 8.4.1, 12 | so as that comes into wider usage if we need to track `containers` API changes going forward and those need CPP we can just drop support for 8.2.2. 13 | 14 | It is intended that you will remap the names of the modules. from `Set.*` or `Map.*` to some portion of the namespace that is peculiar to your 15 | project, and so the module names are designed to be as short as possible, mirroring the usage of `containers` but with the `Data` prefix stripped off. 16 | 17 | Usage 18 | ----- 19 | 20 | To work this into an existing haskell project, you'll need to be on GHC >= 8.2.2, and use cabal >= 2. 21 | 22 | First build an internal library for your project that has a module that matches the `Key` signature. 23 | 24 | ``` 25 | module MyKey where 26 | 27 | type Key = () 28 | ``` 29 | 30 | You can put whatever you want in for `Key` as long as it is an instance of `Ord`. 31 | 32 | Then in your cabal file you can set up your internal library as an extra named internal library (multiple library support was added in cabal 2). 33 | 34 | ``` 35 | library my-keys 36 | exposed-modules: MyKey 37 | build-depends: base 38 | ``` 39 | 40 | and in your library or executable that wants to work with sets or maps of that key type use 41 | 42 | 43 | ``` 44 | library 45 | build-depends: unpacked-containers, my-keys 46 | mixins: unpacked-containers (Set as MyKey.Set) requires (Key as MyKey) 47 | ``` 48 | 49 | If you need several `Set`s or `Map`s you can use several `mixins:` clauses. 50 | 51 | If you need to expose the set type, remember you can use a `reexported-modules:` stanza. 52 | 53 | Now you work with `MyKey.Set` as a monomorphic set type specific to the type of `Key` you specified earlier. 54 | 55 | See the `executable unpacked-set-example` and `library example` sections in the `unpacked-containers.cabal` file for a minimal working example. 56 | 57 | Documentation 58 | == 59 | 60 | To build haddocks for this project you need to run `cabal new-haddock` as `cabal-haddock` doesn't work. 61 | 62 | Contact Information 63 | ------------------- 64 | 65 | Contributions and bug reports are welcome! 66 | 67 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 68 | 69 | -Edward Kmett 70 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/src/HashMap/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} 11 | 12 | module HashMap.Base 13 | ( 14 | HashMap(..) 15 | , Leaf(..) 16 | 17 | -- * Construction 18 | , empty 19 | , singleton 20 | 21 | -- * Basic interface 22 | , null 23 | , size 24 | , member 25 | , lookup 26 | , lookupDefault 27 | , (!) 28 | , insert 29 | , insertWith 30 | , unsafeInsert 31 | , delete 32 | , adjust 33 | , update 34 | , alter 35 | 36 | -- * Combine 37 | -- ** Union 38 | , union 39 | , unionWith 40 | , unionWithKey 41 | , unions 42 | 43 | -- * Transformations 44 | , map 45 | , mapWithKey 46 | , traverseWithKey 47 | 48 | -- * Difference and intersection 49 | , difference 50 | , differenceWith 51 | , intersection 52 | , intersectionWith 53 | , intersectionWithKey 54 | 55 | -- * Folds 56 | , foldl' 57 | , foldlWithKey' 58 | , foldr 59 | , foldrWithKey 60 | 61 | -- * Filter 62 | , mapMaybe 63 | , mapMaybeWithKey 64 | , filter 65 | , filterWithKey 66 | 67 | -- * Conversions 68 | , keys 69 | , elems 70 | 71 | -- ** Lists 72 | , toList 73 | , fromList 74 | , fromListWith 75 | 76 | -- Internals used by the strict version 77 | , Hash 78 | , Bitmap 79 | , bitmapIndexedOrFull 80 | , collision 81 | , hash 82 | , mask 83 | , index 84 | , bitsPerSubkey 85 | , fullNodeMask 86 | , sparseIndex 87 | , two 88 | , unionArrayBy 89 | , update16 90 | , update16M 91 | , update16With' 92 | , updateOrConcatWith 93 | , updateOrConcatWithKey 94 | , filterMapAux 95 | , equalKeys 96 | ) where 97 | 98 | import Control.DeepSeq (NFData(rnf)) 99 | import Control.Monad.ST (ST, runST) 100 | import Data.Bits ((.&.), (.|.), complement, popCount) 101 | import Data.Data hiding (Typeable) 102 | import qualified Data.Foldable as Foldable 103 | import Data.Functor.Classes 104 | import Data.Hashable (Hashable) 105 | import qualified Data.Hashable as H 106 | import qualified Data.Hashable.Lifted as H 107 | import qualified Data.List as L 108 | import Data.Semigroup (Semigroup((<>))) 109 | import GHC.Exts ((==#), build, reallyUnsafePtrEquality#, isTrue#) 110 | import qualified GHC.Exts as Exts 111 | import Prelude hiding (filter, foldr, lookup, map, null, pred) 112 | import Text.Read hiding (step) 113 | 114 | import qualified Internal.Array as A 115 | import Internal.UnsafeShift (unsafeShiftL, unsafeShiftR) 116 | import Internal.List (isPermutationBy, unorderedCompare) 117 | 118 | import Key 119 | 120 | -- | A set of values. A set cannot contain duplicate values. 121 | ------------------------------------------------------------------------ 122 | 123 | -- | Convenience function. Compute a hash value for the given value. 124 | hash :: H.Hashable a => a -> Hash 125 | hash = fromIntegral . H.hash 126 | 127 | data Leaf v = L !Key v 128 | deriving (Eq) 129 | 130 | instance (NFData Key, NFData v) => NFData (Leaf v) where 131 | rnf (L k v) = rnf k `seq` rnf v 132 | 133 | -- Invariant: The length of the 1st argument to 'Full' is 134 | -- 2^bitsPerSubkey 135 | 136 | -- | A map from keys to values. A map cannot contain duplicate keys; 137 | -- each key can map to at most one value. 138 | data HashMap v 139 | = Empty 140 | | BitmapIndexed !Bitmap !(A.Array (HashMap v)) 141 | | Leaf !Hash !(Leaf v) 142 | | Full !(A.Array (HashMap v)) 143 | | Collision !Hash !(A.Array (Leaf v)) 144 | 145 | type role HashMap representational 146 | 147 | instance (NFData Key, NFData v) => NFData (HashMap v) where 148 | rnf Empty = () 149 | rnf (BitmapIndexed _ ary) = rnf ary 150 | rnf (Leaf _ l) = rnf l 151 | rnf (Full ary) = rnf ary 152 | rnf (Collision _ ary) = rnf ary 153 | 154 | instance Functor HashMap where 155 | fmap = map 156 | 157 | instance Foldable.Foldable HashMap where 158 | foldr f = foldrWithKey (const f) 159 | 160 | instance Semigroup (HashMap v) where 161 | (<>) = union 162 | {-# INLINE (<>) #-} 163 | 164 | instance Monoid (HashMap v) where 165 | mempty = empty 166 | {-# INLINE mempty #-} 167 | mappend = (<>) 168 | {-# INLINE mappend #-} 169 | 170 | instance (Data Key, Data v) => Data (HashMap v) where 171 | gfoldl f z m = z fromList `f` toList m 172 | toConstr _ = fromListConstr 173 | gunfold k z c = case constrIndex c of 174 | 1 -> k (z fromList) 175 | _ -> error "gunfold" 176 | dataTypeOf _ = hashMapDataType 177 | dataCast1 f = gcast1 f 178 | 179 | fromListConstr :: Constr 180 | fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix 181 | 182 | hashMapDataType :: DataType 183 | hashMapDataType = mkDataType "HashMap.Base.HashMap" [fromListConstr] 184 | 185 | type Hash = Word 186 | type Bitmap = Word 187 | type Shift = Int 188 | 189 | instance Show Key => Show1 HashMap where 190 | liftShowsPrec spv slv d m = showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) 191 | where 192 | sp = liftShowsPrec spv slv 193 | sl = liftShowList spv slv 194 | 195 | instance Read Key => Read1 HashMap where 196 | liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList 197 | where 198 | rp' = liftReadsPrec rp rl 199 | rl' = liftReadList rp rl 200 | 201 | instance (Read Key, Read e) => Read (HashMap e) where 202 | readPrec = parens $ prec 10 $ do 203 | Ident "fromList" <- lexP 204 | xs <- readPrec 205 | return (fromList xs) 206 | 207 | readListPrec = readListPrecDefault 208 | 209 | instance (Show Key, Show v) => Show (HashMap v) where 210 | showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) 211 | 212 | instance Traversable HashMap where 213 | traverse f = traverseWithKey (const f) 214 | 215 | instance Eq1 HashMap where 216 | liftEq = equal 217 | 218 | instance Eq v => Eq (HashMap v) where 219 | (==) = equal (==) 220 | 221 | equal :: (v -> v' -> Bool) -> HashMap v -> HashMap v' -> Bool 222 | equal eqv t1 t2 = go (toList' t1 []) (toList' t2 []) 223 | where 224 | -- If the two trees are the same, then their lists of 'Leaf's and 225 | -- 'Collision's read from left to right should be the same (modulo the 226 | -- order of elements in 'Collision'). 227 | 228 | go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) 229 | | k1 == k2 && 230 | leafEq l1 l2 231 | = go tl1 tl2 232 | go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) 233 | | k1 == k2 && 234 | A.length ary1 == A.length ary2 && 235 | isPermutationBy leafEq (A.toList ary1) (A.toList ary2) 236 | = go tl1 tl2 237 | go [] [] = True 238 | go _ _ = False 239 | leafEq (L k v) (L k' v') = k == k' && eqv v v' 240 | 241 | instance Ord Key => Ord1 HashMap where 242 | liftCompare = cmp compare 243 | 244 | -- | The order is total. 245 | -- 246 | -- /Note:/ Because the hash is not guaranteed to be stable across library 247 | -- versions, OSes, or architectures, neither is an actual order of elements in 248 | -- 'HashMap' or an result of `compare`.is stable. 249 | instance (Ord Key, Ord v) => Ord (HashMap v) where 250 | compare = cmp compare compare 251 | 252 | cmp :: (Key -> Key -> Ordering) -> (v -> v' -> Ordering) 253 | -> HashMap v -> HashMap v' -> Ordering 254 | cmp cmpk cmpv t1 t2 = go (toList' t1 []) (toList' t2 []) 255 | where 256 | go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) 257 | = compare k1 k2 `mappend` 258 | leafCompare l1 l2 `mappend` 259 | go tl1 tl2 260 | go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) 261 | = compare k1 k2 `mappend` 262 | compare (A.length ary1) (A.length ary2) `mappend` 263 | unorderedCompare leafCompare (A.toList ary1) (A.toList ary2) `mappend` 264 | go tl1 tl2 265 | go (Leaf _ _ : _) (Collision _ _ : _) = LT 266 | go (Collision _ _ : _) (Leaf _ _ : _) = GT 267 | go [] [] = EQ 268 | go [] _ = LT 269 | go _ [] = GT 270 | go _ _ = error "cmp: Should never happend, toList' includes non Leaf / Collision" 271 | 272 | leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v' 273 | 274 | -- Same as 'equal' but doesn't compare the values. 275 | equalKeys :: (Key -> Key -> Bool) -> HashMap v -> HashMap v' -> Bool 276 | equalKeys eq t1 t2 = go (toList' t1 []) (toList' t2 []) 277 | where 278 | go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) 279 | | k1 == k2 && leafEq l1 l2 280 | = go tl1 tl2 281 | go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) 282 | | k1 == k2 && A.length ary1 == A.length ary2 && 283 | isPermutationBy leafEq (A.toList ary1) (A.toList ary2) 284 | = go tl1 tl2 285 | go [] [] = True 286 | go _ _ = False 287 | 288 | leafEq (L k _) (L k' _) = eq k k' 289 | 290 | instance H.Hashable1 HashMap where 291 | liftHashWithSalt hv salt hm = go salt (toList' hm []) 292 | where 293 | -- go :: Int -> [HashMap v] -> Int 294 | go s [] = s 295 | go s (Leaf _ l : tl) 296 | = s `hashLeafWithSalt` l `go` tl 297 | -- For collisions we hashmix hash value 298 | -- and then array of values' hashes sorted 299 | go s (Collision h a : tl) 300 | = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a `go` tl 301 | go s (_ : tl) = s `go` tl 302 | 303 | -- hashLeafWithSalt :: Int -> Leaf v -> Int 304 | hashLeafWithSalt s (L k v) = (s `H.hashWithSalt` k) `hv` v 305 | 306 | -- hashCollisionWithSalt :: Int -> A.Array (Leaf v) -> Int 307 | hashCollisionWithSalt s 308 | = L.foldl' H.hashWithSalt s . arrayHashesSorted s 309 | 310 | -- arrayHashesSorted :: Int -> A.Array (Leaf v) -> [Int] 311 | arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList 312 | 313 | instance Hashable v => Hashable (HashMap v) where 314 | hashWithSalt salt hm = go salt (toList' hm []) 315 | where 316 | go :: Int -> [HashMap v] -> Int 317 | go s [] = s 318 | go s (Leaf _ l : tl) 319 | = s `hashLeafWithSalt` l `go` tl 320 | -- For collisions we hashmix hash value 321 | -- and then array of values' hashes sorted 322 | go s (Collision h a : tl) 323 | = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a `go` tl 324 | go s (_ : tl) = s `go` tl 325 | 326 | hashLeafWithSalt :: Int -> Leaf v -> Int 327 | hashLeafWithSalt s (L k v) = s `H.hashWithSalt` k `H.hashWithSalt` v 328 | 329 | hashCollisionWithSalt :: Int -> A.Array (Leaf v) -> Int 330 | hashCollisionWithSalt s 331 | = L.foldl' H.hashWithSalt s . arrayHashesSorted s 332 | 333 | arrayHashesSorted :: Int -> A.Array (Leaf v) -> [Int] 334 | arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList 335 | 336 | -- Helper to get 'Leaf's and 'Collision's as a list. 337 | toList' :: HashMap v -> [HashMap v] -> [HashMap v] 338 | toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary 339 | toList' (Full ary) a = A.foldr toList' a ary 340 | toList' l@(Leaf _ _) a = l : a 341 | toList' c@(Collision _ _) a = c : a 342 | toList' Empty a = a 343 | 344 | -- Helper function to detect 'Leaf's and 'Collision's. 345 | isLeafOrCollision :: HashMap v -> Bool 346 | isLeafOrCollision (Leaf _ _) = True 347 | isLeafOrCollision (Collision _ _) = True 348 | isLeafOrCollision _ = False 349 | 350 | ------------------------------------------------------------------------ 351 | -- * Construction 352 | 353 | -- | /O(1)/ Construct an empty map. 354 | empty :: HashMap v 355 | empty = Empty 356 | 357 | -- | /O(1)/ Construct a map with a single element. 358 | singleton :: Key -> v -> HashMap v 359 | singleton k v = Leaf (hash k) (L k v) 360 | 361 | ------------------------------------------------------------------------ 362 | -- * Basic interface 363 | 364 | -- | /O(1)/ Return 'True' if this map is empty, 'False' otherwise. 365 | null :: HashMap v -> Bool 366 | null Empty = True 367 | null _ = False 368 | 369 | -- | /O(n)/ Return the number of key-value mappings in this map. 370 | size :: HashMap v -> Int 371 | size t = go t 0 372 | where 373 | go Empty !n = n 374 | go (Leaf _ _) n = n + 1 375 | go (BitmapIndexed _ ary) n = A.foldl' (flip go) n ary 376 | go (Full ary) n = A.foldl' (flip go) n ary 377 | go (Collision _ ary) n = n + A.length ary 378 | 379 | -- | /O(log n)/ Return 'True' if the specified key is present in the 380 | -- map, 'False' otherwise. 381 | member :: Key -> HashMap a -> Bool 382 | member k m = case lookup k m of 383 | Nothing -> False 384 | Just _ -> True 385 | {-# INLINABLE member #-} 386 | 387 | -- | /O(log n)/ Return the value to which the specified key is mapped, 388 | -- or 'Nothing' if this map contains no mapping for the key. 389 | lookup :: Key -> HashMap v -> Maybe v 390 | lookup k0 m0 = go h0 k0 0 m0 391 | where 392 | h0 = hash k0 393 | go !_ !_ !_ Empty = Nothing 394 | go h k _ (Leaf hx (L kx x)) 395 | | h == hx && k == kx = Just x -- TODO: Split test in two 396 | | otherwise = Nothing 397 | go h k s (BitmapIndexed b v) 398 | | b .&. m == 0 = Nothing 399 | | otherwise = go h k (s+bitsPerSubkey) (A.index v (sparseIndex b m)) 400 | where m = mask h s 401 | go h k s (Full v) = go h k (s+bitsPerSubkey) (A.index v (index h s)) 402 | go h k _ (Collision hx v) 403 | | h == hx = lookupInArray k v 404 | | otherwise = Nothing 405 | {-# INLINEABLE lookup #-} 406 | 407 | -- | /O(log n)/ Return the value to which the specified key is mapped, 408 | -- or the default value if this map contains no mapping for the key. 409 | lookupDefault :: v -- ^ Default value to return. 410 | -> Key -> HashMap v -> v 411 | lookupDefault def k t = case lookup k t of 412 | Just v -> v 413 | _ -> def 414 | {-# INLINABLE lookupDefault #-} 415 | 416 | -- | /O(log n)/ Return the value to which the specified key is mapped. 417 | -- Calls 'error' if this map contains no mapping for the key. 418 | (!) :: HashMap v -> Key -> v 419 | (!) m k = case lookup k m of 420 | Just v -> v 421 | Nothing -> error "HashMap.Base.(!): key not found" 422 | {-# INLINABLE (!) #-} 423 | 424 | infixl 9 ! 425 | 426 | -- | Create a 'Collision' value with two 'Leaf' values. 427 | collision :: Hash -> Leaf v -> Leaf v -> HashMap v 428 | collision h e1 e2 = 429 | let v = A.run $ do mary <- A.new 2 e1 430 | A.write mary 1 e2 431 | return mary 432 | in Collision h v 433 | {-# INLINE collision #-} 434 | 435 | -- | Create a 'BitmapIndexed' or 'Full' node. 436 | bitmapIndexedOrFull :: Bitmap -> A.Array (HashMap v) -> HashMap v 437 | bitmapIndexedOrFull b ary 438 | | b == fullNodeMask = Full ary 439 | | otherwise = BitmapIndexed b ary 440 | {-# INLINE bitmapIndexedOrFull #-} 441 | 442 | -- | /O(log n)/ Associate the specified value with the specified 443 | -- key in this map. If this map previously contained a mapping for 444 | -- the key, the old value is replaced. 445 | insert :: Key -> v -> HashMap v -> HashMap v 446 | insert k0 v0 m0 = go h0 k0 v0 0 m0 447 | where 448 | h0 = hash k0 449 | go !h !k x !_ Empty = Leaf h (L k x) 450 | go h k x s t@(Leaf hy l@(L ky y)) 451 | | hy == h = if ky == k 452 | then if x `ptrEq` y 453 | then t 454 | else Leaf h (L k x) 455 | else collision h l (L k x) 456 | | otherwise = runST (two s h k x hy ky y) 457 | go h k x s t@(BitmapIndexed b ary) 458 | | b .&. m == 0 = 459 | let !ary' = A.insert ary i $! Leaf h (L k x) 460 | in bitmapIndexedOrFull (b .|. m) ary' 461 | | otherwise = 462 | let !st = A.index ary i 463 | !st' = go h k x (s+bitsPerSubkey) st 464 | in if st' `ptrEq` st 465 | then t 466 | else BitmapIndexed b (A.update ary i st') 467 | where m = mask h s 468 | i = sparseIndex b m 469 | go h k x s t@(Full ary) = 470 | let !st = A.index ary i 471 | !st' = go h k x (s+bitsPerSubkey) st 472 | in if st' `ptrEq` st 473 | then t 474 | else Full (update16 ary i st') 475 | where i = index h s 476 | go h k x s t@(Collision hy v) 477 | | h == hy = Collision h (updateOrSnocWith const k x v) 478 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 479 | {-# INLINABLE insert #-} 480 | 481 | -- | In-place update version of insert 482 | unsafeInsert :: Key -> v -> HashMap v -> HashMap v 483 | unsafeInsert k0 v0 m0 = runST (go h0 k0 v0 0 m0) 484 | where 485 | h0 = hash k0 486 | go !h !k x !_ Empty = return $! Leaf h (L k x) 487 | go h k x s t@(Leaf hy l@(L ky y)) 488 | | hy == h = if ky == k 489 | then if x `ptrEq` y 490 | then return t 491 | else return $! Leaf h (L k x) 492 | else return $! collision h l (L k x) 493 | | otherwise = two s h k x hy ky y 494 | go h k x s t@(BitmapIndexed b ary) 495 | | b .&. m == 0 = do 496 | ary' <- A.insertM ary i $! Leaf h (L k x) 497 | return $! bitmapIndexedOrFull (b .|. m) ary' 498 | | otherwise = do 499 | st <- A.indexM ary i 500 | st' <- go h k x (s+bitsPerSubkey) st 501 | A.unsafeUpdateM ary i st' 502 | return t 503 | where m = mask h s 504 | i = sparseIndex b m 505 | go h k x s t@(Full ary) = do 506 | st <- A.indexM ary i 507 | st' <- go h k x (s+bitsPerSubkey) st 508 | A.unsafeUpdateM ary i st' 509 | return t 510 | where i = index h s 511 | go h k x s t@(Collision hy v) 512 | | h == hy = return $! Collision h (updateOrSnocWith const k x v) 513 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 514 | {-# INLINEABLE unsafeInsert #-} 515 | 516 | -- | Create a map from two key-value pairs which hashes don't collide. 517 | two :: Shift -> Hash -> Key -> v -> Hash -> Key -> v -> ST s (HashMap v) 518 | two = go 519 | where 520 | go s h1 k1 v1 h2 k2 v2 521 | | bp1 == bp2 = do 522 | st <- go (s+bitsPerSubkey) h1 k1 v1 h2 k2 v2 523 | ary <- A.singletonM st 524 | return $! BitmapIndexed bp1 ary 525 | | otherwise = do 526 | mary <- A.new 2 $ Leaf h1 (L k1 v1) 527 | A.write mary idx2 $ Leaf h2 (L k2 v2) 528 | ary <- A.unsafeFreeze mary 529 | return $! BitmapIndexed (bp1 .|. bp2) ary 530 | where 531 | bp1 = mask h1 s 532 | bp2 = mask h2 s 533 | idx2 | index h1 s < index h2 s = 1 534 | | otherwise = 0 535 | {-# INLINE two #-} 536 | 537 | -- | /O(log n)/ Associate the value with the key in this map. If 538 | -- this map previously contained a mapping for the key, the old value 539 | -- is replaced by the result of applying the given function to the new 540 | -- and old value. Example: 541 | -- 542 | -- > insertWith f k v map 543 | -- > where f new old = new + old 544 | insertWith :: (v -> v -> v) -> Key -> v -> HashMap v -> HashMap v 545 | insertWith f k0 v0 m0 = go h0 k0 v0 0 m0 546 | where 547 | h0 = hash k0 548 | go !h !k x !_ Empty = Leaf h (L k x) 549 | go h k x s (Leaf hy l@(L ky y)) 550 | | hy == h = if ky == k 551 | then Leaf h (L k (f x y)) 552 | else collision h l (L k x) 553 | | otherwise = runST (two s h k x hy ky y) 554 | go h k x s (BitmapIndexed b ary) 555 | | b .&. m == 0 = 556 | let ary' = A.insert ary i $! Leaf h (L k x) 557 | in bitmapIndexedOrFull (b .|. m) ary' 558 | | otherwise = 559 | let st = A.index ary i 560 | st' = go h k x (s+bitsPerSubkey) st 561 | ary' = A.update ary i $! st' 562 | in BitmapIndexed b ary' 563 | where m = mask h s 564 | i = sparseIndex b m 565 | go h k x s (Full ary) = 566 | let st = A.index ary i 567 | st' = go h k x (s+bitsPerSubkey) st 568 | ary' = update16 ary i $! st' 569 | in Full ary' 570 | where i = index h s 571 | go h k x s t@(Collision hy v) 572 | | h == hy = Collision h (updateOrSnocWith f k x v) 573 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 574 | {-# INLINABLE insertWith #-} 575 | 576 | -- | In-place update version of insertWith 577 | unsafeInsertWith :: forall v. (v -> v -> v) -> Key -> v -> HashMap v -> HashMap v 578 | unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0) 579 | where 580 | h0 = hash k0 581 | go :: Hash -> Key -> v -> Shift -> HashMap v -> ST s (HashMap v) 582 | go !h !k x !_ Empty = return $! Leaf h (L k x) 583 | go h k x s (Leaf hy l@(L ky y)) 584 | | hy == h = if ky == k 585 | then return $! Leaf h (L k (f x y)) 586 | else return $! collision h l (L k x) 587 | | otherwise = two s h k x hy ky y 588 | go h k x s t@(BitmapIndexed b ary) 589 | | b .&. m == 0 = do 590 | ary' <- A.insertM ary i $! Leaf h (L k x) 591 | return $! bitmapIndexedOrFull (b .|. m) ary' 592 | | otherwise = do 593 | st <- A.indexM ary i 594 | st' <- go h k x (s+bitsPerSubkey) st 595 | A.unsafeUpdateM ary i st' 596 | return t 597 | where m = mask h s 598 | i = sparseIndex b m 599 | go h k x s t@(Full ary) = do 600 | st <- A.indexM ary i 601 | st' <- go h k x (s+bitsPerSubkey) st 602 | A.unsafeUpdateM ary i st' 603 | return t 604 | where i = index h s 605 | go h k x s t@(Collision hy v) 606 | | h == hy = return $! Collision h (updateOrSnocWith f k x v) 607 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 608 | {-# INLINABLE unsafeInsertWith #-} 609 | 610 | -- | /O(log n)/ Remove the mapping for the specified key from this map 611 | -- if present. 612 | delete :: Key -> HashMap v -> HashMap v 613 | delete k0 m0 = go h0 k0 0 m0 614 | where 615 | h0 = hash k0 616 | go !_ !_ !_ Empty = Empty 617 | go h k _ t@(Leaf hy (L ky _)) 618 | | hy == h && ky == k = Empty 619 | | otherwise = t 620 | go h k s t@(BitmapIndexed b ary) 621 | | b .&. m == 0 = t 622 | | otherwise = 623 | let !st = A.index ary i 624 | !st' = go h k (s+bitsPerSubkey) st 625 | in if st' `ptrEq` st 626 | then t 627 | else case st' of 628 | Empty | A.length ary == 1 -> Empty 629 | | A.length ary == 2 -> 630 | case (i, A.index ary 0, A.index ary 1) of 631 | (0, _, l) | isLeafOrCollision l -> l 632 | (1, l, _) | isLeafOrCollision l -> l 633 | _ -> bIndexed 634 | | otherwise -> bIndexed 635 | where 636 | bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i) 637 | l | isLeafOrCollision l && A.length ary == 1 -> l 638 | _ -> BitmapIndexed b (A.update ary i st') 639 | where m = mask h s 640 | i = sparseIndex b m 641 | go h k s t@(Full ary) = 642 | let !st = A.index ary i 643 | !st' = go h k (s+bitsPerSubkey) st 644 | in if st' `ptrEq` st 645 | then t 646 | else case st' of 647 | Empty -> 648 | let ary' = A.delete ary i 649 | bm = fullNodeMask .&. complement (1 `unsafeShiftL` i) 650 | in BitmapIndexed bm ary' 651 | _ -> Full (A.update ary i st') 652 | where i = index h s 653 | go h k _ t@(Collision hy v) 654 | | h == hy = case indexOf k v of 655 | Just i 656 | | A.length v == 2 -> 657 | if i == 0 658 | then Leaf h (A.index v 1) 659 | else Leaf h (A.index v 0) 660 | | otherwise -> Collision h (A.delete v i) 661 | Nothing -> t 662 | | otherwise = t 663 | {-# INLINABLE delete #-} 664 | 665 | -- | /O(log n)/ Adjust the value tied to a given key in this map only 666 | -- if it is present. Otherwise, leave the map alone. 667 | adjust :: (v -> v) -> Key -> HashMap v -> HashMap v 668 | adjust f k0 m0 = go h0 k0 0 m0 669 | where 670 | h0 = hash k0 671 | go !_ !_ !_ Empty = Empty 672 | go h k _ t@(Leaf hy (L ky y)) 673 | | hy == h && ky == k = Leaf h (L k (f y)) 674 | | otherwise = t 675 | go h k s t@(BitmapIndexed b ary) 676 | | b .&. m == 0 = t 677 | | otherwise = let st = A.index ary i 678 | st' = go h k (s+bitsPerSubkey) st 679 | ary' = A.update ary i $! st' 680 | in BitmapIndexed b ary' 681 | where m = mask h s 682 | i = sparseIndex b m 683 | go h k s (Full ary) = 684 | let i = index h s 685 | st = A.index ary i 686 | st' = go h k (s+bitsPerSubkey) st 687 | ary' = update16 ary i $! st' 688 | in Full ary' 689 | go h k _ t@(Collision hy v) 690 | | h == hy = Collision h (updateWith f k v) 691 | | otherwise = t 692 | {-# INLINABLE adjust #-} 693 | 694 | -- | /O(log n)/ The expression (@'update' f k map@) updates the value @x@ at @k@, 695 | -- (if it is in the map). If (f k x) is @'Nothing', the element is deleted. 696 | -- If it is (@'Just' y), the key k is bound to the new value y. 697 | update :: (a -> Maybe a) -> Key -> HashMap a -> HashMap a 698 | update f = alter (>>= f) 699 | {-# INLINABLE update #-} 700 | 701 | 702 | -- | /O(log n)/ The expression (@'alter' f k map@) alters the value @x@ at @k@, or 703 | -- absence thereof. @alter@ can be used to insert, delete, or update a value in a 704 | -- map. In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. 705 | alter :: (Maybe v -> Maybe v) -> Key -> HashMap v -> HashMap v 706 | alter f k m = 707 | case f (lookup k m) of 708 | Nothing -> delete k m 709 | Just v -> insert k v m 710 | {-# INLINABLE alter #-} 711 | 712 | ------------------------------------------------------------------------ 713 | -- * Combine 714 | 715 | -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, the 716 | -- mapping from the first will be the mapping in the result. 717 | union :: HashMap v -> HashMap v -> HashMap v 718 | union = unionWith const 719 | {-# INLINABLE union #-} 720 | 721 | -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, 722 | -- the provided function (first argument) will be used to compute the 723 | -- result. 724 | unionWith :: (v -> v -> v) -> HashMap v -> HashMap v -> HashMap v 725 | unionWith f = unionWithKey (const f) 726 | {-# INLINE unionWith #-} 727 | 728 | -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, 729 | -- the provided function (first argument) will be used to compute the 730 | -- result. 731 | unionWithKey :: (Key -> v -> v -> v) -> HashMap v -> HashMap v -> HashMap v 732 | unionWithKey f = go 0 733 | where 734 | -- empty vs. anything 735 | go !_ t1 Empty = t1 736 | go _ Empty t2 = t2 737 | -- leaf vs. leaf 738 | go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) 739 | | h1 == h2 = if k1 == k2 740 | then Leaf h1 (L k1 (f k1 v1 v2)) 741 | else collision h1 l1 l2 742 | | otherwise = goDifferentHash s h1 h2 t1 t2 743 | go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) 744 | | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2) 745 | | otherwise = goDifferentHash s h1 h2 t1 t2 746 | go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) 747 | | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) 748 | | otherwise = goDifferentHash s h1 h2 t1 t2 749 | go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) 750 | | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2) 751 | | otherwise = goDifferentHash s h1 h2 t1 t2 752 | -- branch vs. branch 753 | go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = 754 | let b' = b1 .|. b2 755 | ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 756 | in bitmapIndexedOrFull b' ary' 757 | go s (BitmapIndexed b1 ary1) (Full ary2) = 758 | let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 759 | in Full ary' 760 | go s (Full ary1) (BitmapIndexed b2 ary2) = 761 | let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 762 | in Full ary' 763 | go s (Full ary1) (Full ary2) = 764 | let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask 765 | ary1 ary2 766 | in Full ary' 767 | -- leaf vs. branch 768 | go s (BitmapIndexed b1 ary1) t2 769 | | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 770 | b' = b1 .|. m2 771 | in bitmapIndexedOrFull b' ary' 772 | | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> 773 | go (s+bitsPerSubkey) st1 t2 774 | in BitmapIndexed b1 ary' 775 | where 776 | h2 = leafHashCode t2 777 | m2 = mask h2 s 778 | i = sparseIndex b1 m2 779 | go s t1 (BitmapIndexed b2 ary2) 780 | | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 781 | b' = b2 .|. m1 782 | in bitmapIndexedOrFull b' ary' 783 | | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> 784 | go (s+bitsPerSubkey) t1 st2 785 | in BitmapIndexed b2 ary' 786 | where 787 | h1 = leafHashCode t1 788 | m1 = mask h1 s 789 | i = sparseIndex b2 m1 790 | go s (Full ary1) t2 = 791 | let h2 = leafHashCode t2 792 | i = index h2 s 793 | ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 794 | in Full ary' 795 | go s t1 (Full ary2) = 796 | let h1 = leafHashCode t1 797 | i = index h1 s 798 | ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 799 | in Full ary' 800 | 801 | leafHashCode (Leaf h _) = h 802 | leafHashCode (Collision h _) = h 803 | leafHashCode _ = error "leafHashCode" 804 | 805 | goDifferentHash s h1 h2 t1 t2 806 | | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) 807 | | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) 808 | | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) 809 | where 810 | m1 = mask h1 s 811 | m2 = mask h2 s 812 | {-# INLINE unionWithKey #-} 813 | 814 | -- | Strict in the result of @f@. 815 | unionArrayBy :: (a -> a -> a) -> Bitmap -> Bitmap -> A.Array a -> A.Array a 816 | -> A.Array a 817 | unionArrayBy f b1 b2 ary1 ary2 = A.run $ do 818 | let b' = b1 .|. b2 819 | mary <- A.new_ (popCount b') 820 | -- iterate over nonzero bits of b1 .|. b2 821 | -- it would be nice if we could shift m by more than 1 each time 822 | let ba = b1 .&. b2 823 | go !i !i1 !i2 !m 824 | | m > b' = return () 825 | | b' .&. m == 0 = go i i1 i2 (m `unsafeShiftL` 1) 826 | | ba .&. m /= 0 = do 827 | A.write mary i $! f (A.index ary1 i1) (A.index ary2 i2) 828 | go (i+1) (i1+1) (i2+1) (m `unsafeShiftL` 1) 829 | | b1 .&. m /= 0 = do 830 | A.write mary i =<< A.indexM ary1 i1 831 | go (i+1) (i1+1) (i2 ) (m `unsafeShiftL` 1) 832 | | otherwise = do 833 | A.write mary i =<< A.indexM ary2 i2 834 | go (i+1) (i1 ) (i2+1) (m `unsafeShiftL` 1) 835 | go 0 0 0 (b' .&. negate b') -- XXX: b' must be non-zero 836 | return mary 837 | -- TODO: For the case where b1 .&. b2 == b1, i.e. when one is a 838 | -- subset of the other, we could use a slightly simpler algorithm, 839 | -- where we copy one array, and then update. 840 | {-# INLINE unionArrayBy #-} 841 | 842 | -- TODO: Figure out the time complexity of 'unions'. 843 | 844 | -- | Construct a set containing all elements from a list of sets. 845 | unions :: [HashMap v] -> HashMap v 846 | unions = L.foldl' union empty 847 | {-# INLINE unions #-} 848 | 849 | ------------------------------------------------------------------------ 850 | -- * Transformations 851 | 852 | -- | /O(n)/ Transform this map by applying a function to every value. 853 | mapWithKey :: (Key -> v1 -> v2) -> HashMap v1 -> HashMap v2 854 | mapWithKey f = go 855 | where 856 | go Empty = Empty 857 | go (Leaf h (L k v)) = Leaf h $ L k (f k v) 858 | go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary 859 | go (Full ary) = Full $ A.map' go ary 860 | go (Collision h ary) = Collision h $ 861 | A.map' (\ (L k v) -> L k (f k v)) ary 862 | {-# INLINE mapWithKey #-} 863 | 864 | -- | /O(n)/ Transform this map by applying a function to every value. 865 | map :: (v1 -> v2) -> HashMap v1 -> HashMap v2 866 | map f = mapWithKey (const f) 867 | {-# INLINE map #-} 868 | 869 | -- TODO: We should be able to use mutation to create the new 870 | -- 'HashMap'. 871 | 872 | -- | /O(n)/ Transform this map by accumulating an Applicative result 873 | -- from every value. 874 | traverseWithKey :: Applicative f => (Key -> v1 -> f v2) -> HashMap v1 875 | -> f (HashMap v2) 876 | traverseWithKey f = go 877 | where 878 | go Empty = pure Empty 879 | go (Leaf h (L k v)) = Leaf h . L k <$> f k v 880 | go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse go ary 881 | go (Full ary) = Full <$> A.traverse go ary 882 | go (Collision h ary) = 883 | Collision h <$> A.traverse (\ (L k v) -> L k <$> f k v) ary 884 | {-# INLINE traverseWithKey #-} 885 | 886 | ------------------------------------------------------------------------ 887 | -- * Difference and intersection 888 | 889 | -- | /O(n*log m)/ Difference of two maps. Return elements of the first map 890 | -- not existing in the second. 891 | difference :: HashMap v -> HashMap w -> HashMap v 892 | difference a b = foldlWithKey' go empty a 893 | where 894 | go m k v = case lookup k b of 895 | Nothing -> insert k v m 896 | _ -> m 897 | {-# INLINABLE difference #-} 898 | 899 | -- | /O(n*log m)/ Difference with a combining function. When two equal keys are 900 | -- encountered, the combining function is applied to the values of these keys. 901 | -- If it returns 'Nothing', the element is discarded (proper set difference). If 902 | -- it returns (@'Just' y@), the element is updated with a new value @y@. 903 | differenceWith :: (v -> w -> Maybe v) -> HashMap v -> HashMap w -> HashMap v 904 | differenceWith f a b = foldlWithKey' go empty a 905 | where 906 | go m k v = case lookup k b of 907 | Nothing -> insert k v m 908 | Just w -> maybe m (\y -> insert k y m) (f v w) 909 | {-# INLINABLE differenceWith #-} 910 | 911 | -- | /O(n*log m)/ Intersection of two maps. Return elements of the first 912 | -- map for keys existing in the second. 913 | intersection :: HashMap v -> HashMap w -> HashMap v 914 | intersection a b = foldlWithKey' go empty a 915 | where 916 | go m k v = case lookup k b of 917 | Just _ -> insert k v m 918 | _ -> m 919 | {-# INLINABLE intersection #-} 920 | 921 | -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps 922 | -- the provided function is used to combine the values from the two 923 | -- maps. 924 | intersectionWith :: (v1 -> v2 -> v3) -> HashMap v1 925 | -> HashMap v2 -> HashMap v3 926 | intersectionWith f a b = foldlWithKey' go empty a 927 | where 928 | go m k v = case lookup k b of 929 | Just w -> insert k (f v w) m 930 | _ -> m 931 | {-# INLINABLE intersectionWith #-} 932 | 933 | -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps 934 | -- the provided function is used to combine the values from the two 935 | -- maps. 936 | intersectionWithKey :: (Key -> v1 -> v2 -> v3) 937 | -> HashMap v1 -> HashMap v2 -> HashMap v3 938 | intersectionWithKey f a b = foldlWithKey' go empty a 939 | where 940 | go m k v = case lookup k b of 941 | Just w -> insert k (f k v w) m 942 | _ -> m 943 | {-# INLINABLE intersectionWithKey #-} 944 | 945 | ------------------------------------------------------------------------ 946 | -- * Folds 947 | 948 | -- | /O(n)/ Reduce this map by applying a binary operator to all 949 | -- elements, using the given starting value (typically the 950 | -- left-identity of the operator). Each application of the operator 951 | -- is evaluated before before using the result in the next 952 | -- application. This function is strict in the starting value. 953 | foldl' :: (a -> v -> a) -> a -> HashMap v -> a 954 | foldl' f = foldlWithKey' (\ z _ v -> f z v) 955 | {-# INLINE foldl' #-} 956 | 957 | -- | /O(n)/ Reduce this map by applying a binary operator to all 958 | -- elements, using the given starting value (typically the 959 | -- left-identity of the operator). Each application of the operator 960 | -- is evaluated before before using the result in the next 961 | -- application. This function is strict in the starting value. 962 | foldlWithKey' :: (a -> Key -> v -> a) -> a -> HashMap v -> a 963 | foldlWithKey' f = go 964 | where 965 | go !z Empty = z 966 | go z (Leaf _ (L k v)) = f z k v 967 | go z (BitmapIndexed _ ary) = A.foldl' go z ary 968 | go z (Full ary) = A.foldl' go z ary 969 | go z (Collision _ ary) = A.foldl' (\ z' (L k v) -> f z' k v) z ary 970 | {-# INLINE foldlWithKey' #-} 971 | 972 | -- | /O(n)/ Reduce this map by applying a binary operator to all 973 | -- elements, using the given starting value (typically the 974 | -- right-identity of the operator). 975 | foldr :: (v -> a -> a) -> a -> HashMap v -> a 976 | foldr f = foldrWithKey (const f) 977 | {-# INLINE foldr #-} 978 | 979 | -- | /O(n)/ Reduce this map by applying a binary operator to all 980 | -- elements, using the given starting value (typically the 981 | -- right-identity of the operator). 982 | foldrWithKey :: (Key -> v -> a -> a) -> a -> HashMap v -> a 983 | foldrWithKey f = go 984 | where 985 | go z Empty = z 986 | go z (Leaf _ (L k v)) = f k v z 987 | go z (BitmapIndexed _ ary) = A.foldr (flip go) z ary 988 | go z (Full ary) = A.foldr (flip go) z ary 989 | go z (Collision _ ary) = A.foldr (\ (L k v) z' -> f k v z') z ary 990 | {-# INLINE foldrWithKey #-} 991 | 992 | ------------------------------------------------------------------------ 993 | -- * Filter 994 | 995 | -- | Create a new array of the @n@ first elements of @mary@. 996 | trim :: A.MArray s a -> Int -> ST s (A.Array a) 997 | trim mary n = do 998 | mary2 <- A.new_ n 999 | A.copyM mary 0 mary2 0 n 1000 | A.unsafeFreeze mary2 1001 | {-# INLINE trim #-} 1002 | 1003 | -- | /O(n)/ Transform this map by applying a function to every value 1004 | -- and retaining only some of them. 1005 | mapMaybeWithKey :: (Key -> v1 -> Maybe v2) -> HashMap v1 -> HashMap v2 1006 | mapMaybeWithKey f = filterMapAux onLeaf onColl 1007 | where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (Leaf h (L k v')) 1008 | onLeaf _ = Nothing 1009 | 1010 | onColl (L k v) | Just v' <- f k v = Just (L k v') 1011 | | otherwise = Nothing 1012 | {-# INLINE mapMaybeWithKey #-} 1013 | 1014 | -- | /O(n)/ Transform this map by applying a function to every value 1015 | -- and retaining only some of them. 1016 | mapMaybe :: (v1 -> Maybe v2) -> HashMap v1 -> HashMap v2 1017 | mapMaybe f = mapMaybeWithKey (const f) 1018 | {-# INLINE mapMaybe #-} 1019 | 1020 | -- | /O(n)/ Filter this map by retaining only elements satisfying a 1021 | -- predicate. 1022 | filterWithKey :: (Key -> v -> Bool) -> HashMap v -> HashMap v 1023 | filterWithKey pred = filterMapAux onLeaf onColl 1024 | where onLeaf t@(Leaf _ (L k v)) | pred k v = Just t 1025 | onLeaf _ = Nothing 1026 | 1027 | onColl el@(L k v) | pred k v = Just el 1028 | onColl _ = Nothing 1029 | {-# INLINE filterWithKey #-} 1030 | 1031 | 1032 | -- | Common implementation for 'filterWithKey' and 'mapMaybeWithKey', 1033 | -- allowing the former to former to reuse terms. 1034 | filterMapAux :: forall v1 v2. 1035 | (HashMap v1 -> Maybe (HashMap v2)) 1036 | -> (Leaf v1 -> Maybe (Leaf v2)) 1037 | -> HashMap v1 1038 | -> HashMap v2 1039 | filterMapAux onLeaf onColl = go 1040 | where 1041 | go Empty = Empty 1042 | go t@Leaf{} 1043 | | Just t' <- onLeaf t = t' 1044 | | otherwise = Empty 1045 | go (BitmapIndexed b ary) = filterA ary b 1046 | go (Full ary) = filterA ary fullNodeMask 1047 | go (Collision h ary) = filterC ary h 1048 | 1049 | filterA ary0 b0 = 1050 | let !n = A.length ary0 1051 | in runST $ do 1052 | mary <- A.new_ n 1053 | step ary0 mary b0 0 0 1 n 1054 | where 1055 | step :: A.Array (HashMap v1) -> A.MArray s (HashMap v2) 1056 | -> Bitmap -> Int -> Int -> Bitmap -> Int 1057 | -> ST s (HashMap v2) 1058 | step !ary !mary !b i !j !bi n 1059 | | i >= n = case j of 1060 | 0 -> return Empty 1061 | 1 -> do 1062 | ch <- A.read mary 0 1063 | case ch of 1064 | t | isLeafOrCollision t -> return t 1065 | _ -> BitmapIndexed b <$> trim mary 1 1066 | _ -> do 1067 | ary2 <- trim mary j 1068 | return $! if j == maxChildren 1069 | then Full ary2 1070 | else BitmapIndexed b ary2 1071 | | bi .&. b == 0 = step ary mary b i j (bi `unsafeShiftL` 1) n 1072 | | otherwise = case go (A.index ary i) of 1073 | Empty -> step ary mary (b .&. complement bi) (i+1) j 1074 | (bi `unsafeShiftL` 1) n 1075 | t -> do A.write mary j t 1076 | step ary mary b (i+1) (j+1) (bi `unsafeShiftL` 1) n 1077 | 1078 | filterC ary0 h = 1079 | let !n = A.length ary0 1080 | in runST $ do 1081 | mary <- A.new_ n 1082 | step ary0 mary 0 0 n 1083 | where 1084 | step :: A.Array (Leaf v1) -> A.MArray s (Leaf v2) 1085 | -> Int -> Int -> Int 1086 | -> ST s (HashMap v2) 1087 | step !ary !mary i !j n 1088 | | i >= n = case j of 1089 | 0 -> return Empty 1090 | 1 -> do l <- A.read mary 0 1091 | return $! Leaf h l 1092 | _ | i == j -> do ary2 <- A.unsafeFreeze mary 1093 | return $! Collision h ary2 1094 | | otherwise -> do ary2 <- trim mary j 1095 | return $! Collision h ary2 1096 | | Just el <- onColl (A.index ary i) 1097 | = A.write mary j el >> step ary mary (i+1) (j+1) n 1098 | | otherwise = step ary mary (i+1) j n 1099 | {-# INLINE filterMapAux #-} 1100 | 1101 | -- | /O(n)/ Filter this map by retaining only elements which values 1102 | -- satisfy a predicate. 1103 | filter :: (v -> Bool) -> HashMap v -> HashMap v 1104 | filter p = filterWithKey (\_ v -> p v) 1105 | {-# INLINE filter #-} 1106 | 1107 | ------------------------------------------------------------------------ 1108 | -- * Conversions 1109 | 1110 | -- TODO: Improve fusion rules by modelled them after the Prelude ones 1111 | -- on lists. 1112 | 1113 | -- | /O(n)/ Return a list of this map's keys. The list is produced 1114 | -- lazily. 1115 | keys :: HashMap v -> [Key] 1116 | keys = L.map fst . toList 1117 | {-# INLINE keys #-} 1118 | 1119 | -- | /O(n)/ Return a list of this map's values. The list is produced 1120 | -- lazily. 1121 | elems :: HashMap v -> [v] 1122 | elems = L.map snd . toList 1123 | {-# INLINE elems #-} 1124 | 1125 | ------------------------------------------------------------------------ 1126 | -- ** Lists 1127 | 1128 | -- | /O(n)/ Return a list of this map's elements. The list is 1129 | -- produced lazily. The order of its elements is unspecified. 1130 | toList :: HashMap v -> [(Key, v)] 1131 | toList t = build (\ c z -> foldrWithKey (curry c) z t) 1132 | {-# INLINE toList #-} 1133 | 1134 | -- | /O(n)/ Construct a map with the supplied mappings. If the list 1135 | -- contains duplicate mappings, the later mappings take precedence. 1136 | fromList :: [(Key, v)] -> HashMap v 1137 | fromList = L.foldl' (\ m (k, v) -> unsafeInsert k v m) empty 1138 | {-# INLINABLE fromList #-} 1139 | 1140 | -- | /O(n*log n)/ Construct a map from a list of elements. Uses 1141 | -- the provided function to merge duplicate entries. 1142 | fromListWith :: (v -> v -> v) -> [(Key, v)] -> HashMap v 1143 | fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty 1144 | {-# INLINE fromListWith #-} 1145 | 1146 | ------------------------------------------------------------------------ 1147 | -- Array operations 1148 | 1149 | -- | /O(n)/ Lookup the value associated with the given key in this 1150 | -- array. Returns 'Nothing' if the key wasn't found. 1151 | lookupInArray :: Key -> A.Array (Leaf v) -> Maybe v 1152 | lookupInArray k0 ary0 = go k0 ary0 0 (A.length ary0) 1153 | where 1154 | go !k !ary !i !n 1155 | | i >= n = Nothing 1156 | | otherwise = case A.index ary i of 1157 | (L kx v) 1158 | | k == kx -> Just v 1159 | | otherwise -> go k ary (i+1) n 1160 | 1161 | -- | /O(n)/ Lookup the value associated with the given key in this 1162 | -- array. Returns 'Nothing' if the key wasn't found. 1163 | indexOf :: Key -> A.Array (Leaf v) -> Maybe Int 1164 | indexOf k0 ary0 = go k0 ary0 0 (A.length ary0) 1165 | where 1166 | go !k !ary !i !n 1167 | | i >= n = Nothing 1168 | | otherwise = case A.index ary i of 1169 | (L kx _) 1170 | | k == kx -> Just i 1171 | | otherwise -> go k ary (i+1) n 1172 | {-# INLINEABLE indexOf #-} 1173 | 1174 | updateWith :: (v -> v) -> Key -> A.Array (Leaf v) -> A.Array (Leaf v) 1175 | updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) 1176 | where 1177 | go !k !ary !i !n 1178 | | i >= n = ary 1179 | | otherwise = case A.index ary i of 1180 | (L kx y) | k == kx -> A.update ary i (L k (f y)) 1181 | | otherwise -> go k ary (i+1) n 1182 | {-# INLINABLE updateWith #-} 1183 | 1184 | updateOrSnocWith :: (v -> v -> v) -> Key -> v -> A.Array (Leaf v) -> A.Array (Leaf v) 1185 | updateOrSnocWith f = updateOrSnocWithKey (const f) 1186 | {-# INLINABLE updateOrSnocWith #-} 1187 | 1188 | updateOrSnocWithKey :: (Key -> v -> v -> v) -> Key -> v -> A.Array (Leaf v) -> A.Array (Leaf v) 1189 | updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) 1190 | where 1191 | go !k v !ary !i !n 1192 | | i >= n = A.run $ do 1193 | -- Not found, append to the end. 1194 | mary <- A.new_ (n + 1) 1195 | A.copy ary 0 mary 0 n 1196 | A.write mary n (L k v) 1197 | return mary 1198 | | otherwise = case A.index ary i of 1199 | (L kx y) | k == kx -> A.update ary i (L k (f k v y)) 1200 | | otherwise -> go k v ary (i+1) n 1201 | {-# INLINABLE updateOrSnocWithKey #-} 1202 | 1203 | updateOrConcatWith :: (v -> v -> v) -> A.Array (Leaf v) -> A.Array (Leaf v) -> A.Array (Leaf v) 1204 | updateOrConcatWith f = updateOrConcatWithKey (const f) 1205 | {-# INLINABLE updateOrConcatWith #-} 1206 | 1207 | updateOrConcatWithKey :: (Key -> v -> v -> v) -> A.Array (Leaf v) -> A.Array (Leaf v) -> A.Array (Leaf v) 1208 | updateOrConcatWithKey f ary1 ary2 = A.run $ do 1209 | -- first: look up the position of each element of ary2 in ary1 1210 | let indices = A.map (\(L k _) -> indexOf k ary1) ary2 1211 | -- that tells us how large the overlap is: 1212 | -- count number of Nothing constructors 1213 | let nOnly2 = A.foldl' (\n -> maybe (n+1) (const n)) 0 indices 1214 | let n1 = A.length ary1 1215 | let n2 = A.length ary2 1216 | -- copy over all elements from ary1 1217 | mary <- A.new_ (n1 + nOnly2) 1218 | A.copy ary1 0 mary 0 n1 1219 | -- append or update all elements from ary2 1220 | let go !iEnd !i2 1221 | | i2 >= n2 = return () 1222 | | otherwise = case A.index indices i2 of 1223 | Just i1 -> do -- key occurs in both arrays, store combination in position i1 1224 | L k v1 <- A.indexM ary1 i1 1225 | L _ v2 <- A.indexM ary2 i2 1226 | A.write mary i1 (L k (f k v1 v2)) 1227 | go iEnd (i2+1) 1228 | Nothing -> do -- key is only in ary2, append to end 1229 | A.write mary iEnd =<< A.indexM ary2 i2 1230 | go (iEnd+1) (i2+1) 1231 | go n1 0 1232 | return mary 1233 | 1234 | ------------------------------------------------------------------------ 1235 | -- Manually unrolled loops 1236 | 1237 | -- | /O(n)/ Update the element at the given position in this array. 1238 | update16 :: A.Array e -> Int -> e -> A.Array e 1239 | update16 ary idx b = runST (update16M ary idx b) 1240 | {-# INLINE update16 #-} 1241 | 1242 | -- | /O(n)/ Update the element at the given position in this array. 1243 | update16M :: A.Array e -> Int -> e -> ST s (A.Array e) 1244 | update16M ary idx b = do 1245 | mary <- clone16 ary 1246 | A.write mary idx b 1247 | A.unsafeFreeze mary 1248 | {-# INLINE update16M #-} 1249 | 1250 | -- | /O(n)/ Update the element at the given position in this array, by applying a function to it. 1251 | update16With' :: A.Array e -> Int -> (e -> e) -> A.Array e 1252 | update16With' ary idx f = update16 ary idx $! f (A.index ary idx) 1253 | {-# INLINE update16With' #-} 1254 | 1255 | -- | Unsafely clone an array of 16 elements. The length of the input 1256 | -- array is not checked. 1257 | clone16 :: A.Array e -> ST s (A.MArray s e) 1258 | clone16 ary = A.thaw ary 0 16 1259 | 1260 | ------------------------------------------------------------------------ 1261 | -- Bit twiddling 1262 | 1263 | bitsPerSubkey :: Int 1264 | bitsPerSubkey = 4 1265 | 1266 | maxChildren :: Int 1267 | maxChildren = fromIntegral $ 1 `unsafeShiftL` bitsPerSubkey 1268 | 1269 | subkeyMask :: Bitmap 1270 | subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1 1271 | 1272 | sparseIndex :: Bitmap -> Bitmap -> Int 1273 | sparseIndex b m = popCount (b .&. (m - 1)) 1274 | 1275 | mask :: Word -> Shift -> Bitmap 1276 | mask w s = 1 `unsafeShiftL` index w s 1277 | {-# INLINE mask #-} 1278 | 1279 | -- | Mask out the 'bitsPerSubkey' bits used for indexing at this level 1280 | -- of the tree. 1281 | index :: Hash -> Shift -> Int 1282 | index w s = fromIntegral $ (unsafeShiftR w s) .&. subkeyMask 1283 | {-# INLINE index #-} 1284 | 1285 | -- | A bitmask with the 'bitsPerSubkey' least significant bits set. 1286 | fullNodeMask :: Bitmap 1287 | fullNodeMask = complement (complement 0 `unsafeShiftL` maxChildren) 1288 | {-# INLINE fullNodeMask #-} 1289 | 1290 | -- | Check if two the two arguments are the same value. N.B. This 1291 | -- function might give false negatives (due to GC moving objects.) 1292 | ptrEq :: a -> a -> Bool 1293 | ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y ==# 1#) 1294 | {-# INLINE ptrEq #-} 1295 | 1296 | ------------------------------------------------------------------------ 1297 | -- IsList instance 1298 | instance Exts.IsList (HashMap v) where 1299 | type Item (HashMap v) = (Key, v) 1300 | fromList = fromList 1301 | toList = toList 1302 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/src/HashMap/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | ------------------------------------------------------------------------ 3 | -- | 4 | -- Module : HashMap.Lazy 5 | -- Copyright : (C) 2010-2012 Johan Tibell 6 | -- (C) 2018 Edward Kmett 7 | -- License : BSD-style 8 | -- Maintainer : ekmett@gmail.com 9 | -- Stability : experimental 10 | -- Portability : nonportable 11 | -- 12 | -- A map from /hashable/ keys to values. A map cannot contain 13 | -- duplicate keys; each key can map to at most one value. A 'HashMap' 14 | -- makes no guarantees as to the order of its elements. 15 | -- 16 | -- The implementation is based on /hash array mapped tries/. A 17 | -- 'HashMap' is often faster than other tree-based set types, 18 | -- especially when key comparison is expensive, as in the case of 19 | -- strings. 20 | -- 21 | -- Many operations have a average-case complexity of /O(log n)/. The 22 | -- implementation uses a large base (i.e. 16) so in practice these 23 | -- operations are constant time. 24 | module HashMap.Lazy 25 | ( 26 | -- * Strictness properties 27 | -- $strictness 28 | 29 | HashMap 30 | 31 | -- * Construction 32 | , empty 33 | , singleton 34 | 35 | -- * Basic interface 36 | , HM.null 37 | , size 38 | , member 39 | , HM.lookup 40 | , lookupDefault 41 | , (!) 42 | , insert 43 | , insertWith 44 | , delete 45 | , adjust 46 | , update 47 | , alter 48 | 49 | -- * Combine 50 | -- ** Union 51 | , union 52 | , unionWith 53 | , unionWithKey 54 | , unions 55 | 56 | -- * Transformations 57 | , HM.map 58 | , mapWithKey 59 | , traverseWithKey 60 | 61 | -- * Difference and intersection 62 | , difference 63 | , differenceWith 64 | , intersection 65 | , intersectionWith 66 | , intersectionWithKey 67 | 68 | -- * Folds 69 | , foldl' 70 | , foldlWithKey' 71 | , HM.foldr 72 | , foldrWithKey 73 | 74 | -- * Filter 75 | , HM.filter 76 | , filterWithKey 77 | , mapMaybe 78 | , mapMaybeWithKey 79 | 80 | -- * Conversions 81 | , keys 82 | , elems 83 | 84 | -- ** Lists 85 | , toList 86 | , fromList 87 | , fromListWith 88 | ) where 89 | 90 | import HashMap.Base as HM 91 | 92 | -- $strictness 93 | -- 94 | -- This module satisfies the following strictness property: 95 | -- 96 | -- * Key arguments are evaluated to WHNF 97 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/src/HashMap/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, CPP, PatternGuards #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | ------------------------------------------------------------------------ 5 | -- | 6 | -- Module : HashMap.Strict 7 | -- Copyright : 2010-2012 Johan Tibell 8 | -- License : BSD-style 9 | -- Maintainer : johan.tibell@gmail.com 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- A map from /hashable/ keys to values. A map cannot contain 14 | -- duplicate keys; each key can map to at most one value. A 'HashMap' 15 | -- makes no guarantees as to the order of its elements. 16 | -- 17 | -- The implementation is based on /hash array mapped tries/. A 18 | -- 'HashMap' is often faster than other tree-based set types, 19 | -- especially when key comparison is expensive, as in the case of 20 | -- strings. 21 | -- 22 | -- Many operations have a average-case complexity of /O(log n)/. The 23 | -- implementation uses a large base (i.e. 16) so in practice these 24 | -- operations are constant time. 25 | module HashMap.Strict 26 | ( 27 | -- * Strictness properties 28 | -- $strictness 29 | 30 | HashMap 31 | 32 | -- * Construction 33 | , empty 34 | , singleton 35 | 36 | -- * Basic interface 37 | , HM.null 38 | , size 39 | , HM.member 40 | , HM.lookup 41 | , lookupDefault 42 | , (!) 43 | , insert 44 | , insertWith 45 | , delete 46 | , adjust 47 | , update 48 | , alter 49 | 50 | -- * Combine 51 | -- ** Union 52 | , union 53 | , unionWith 54 | , unionWithKey 55 | , unions 56 | 57 | -- * Transformations 58 | , map 59 | , mapWithKey 60 | , traverseWithKey 61 | 62 | -- * Difference and intersection 63 | , difference 64 | , differenceWith 65 | , intersection 66 | , intersectionWith 67 | , intersectionWithKey 68 | 69 | -- * Folds 70 | , foldl' 71 | , foldlWithKey' 72 | , HM.foldr 73 | , foldrWithKey 74 | 75 | -- * Filter 76 | , HM.filter 77 | , filterWithKey 78 | , mapMaybe 79 | , mapMaybeWithKey 80 | 81 | -- * Conversions 82 | , keys 83 | , elems 84 | 85 | -- ** Lists 86 | , toList 87 | , fromList 88 | , fromListWith 89 | ) where 90 | 91 | import Control.Monad.ST (runST) 92 | import Data.Bits ((.&.), (.|.)) 93 | import qualified Data.List as L 94 | import Prelude hiding (map) 95 | 96 | import qualified HashMap.Base as HM 97 | import HashMap.Base hiding ( 98 | alter, adjust, fromList, fromListWith, insert, insertWith, differenceWith, 99 | intersectionWith, intersectionWithKey, map, mapWithKey, mapMaybe, 100 | mapMaybeWithKey, singleton, update, unionWith, unionWithKey) 101 | 102 | import qualified Internal.Array as A 103 | 104 | import Key 105 | 106 | -- $strictness 107 | -- 108 | -- This module satisfies the following strictness properties: 109 | -- 110 | -- 1. Key arguments are evaluated to WHNF; 111 | -- 112 | -- 2. Keys and values are evaluated to WHNF before they are stored in 113 | -- the map. 114 | 115 | ------------------------------------------------------------------------ 116 | -- * Construction 117 | 118 | -- | /O(1)/ Construct a map with a single element. 119 | singleton :: Key -> v -> HashMap v 120 | singleton k !v = HM.singleton k v 121 | 122 | ------------------------------------------------------------------------ 123 | -- * Basic interface 124 | 125 | -- | /O(log n)/ Associate the specified value with the specified 126 | -- key in this map. If this map previously contained a mapping for 127 | -- the key, the old value is replaced. 128 | insert :: Key -> v -> HashMap v -> HashMap v 129 | insert k !v = HM.insert k v 130 | {-# INLINABLE insert #-} 131 | 132 | -- | /O(log n)/ Associate the value with the key in this map. If 133 | -- this map previously contained a mapping for the key, the old value 134 | -- is replaced by the result of applying the given function to the new 135 | -- and old value. Example: 136 | -- 137 | -- > insertWith f k v map 138 | -- > where f new old = new + old 139 | insertWith :: (v -> v -> v) -> Key -> v -> HashMap v -> HashMap v 140 | insertWith f k0 v0 m0 = go h0 k0 v0 0 m0 141 | where 142 | h0 = hash k0 143 | go !h !k x !_ Empty = leaf h k x 144 | go h k x s (Leaf hy l@(L ky y)) 145 | | hy == h = if ky == k 146 | then leaf h k (f x y) 147 | else x `seq` (collision h l (L k x)) 148 | | otherwise = x `seq` runST (two s h k x hy ky y) 149 | go h k x s (BitmapIndexed b ary) 150 | | b .&. m == 0 = 151 | let ary' = A.insert ary i $! leaf h k x 152 | in bitmapIndexedOrFull (b .|. m) ary' 153 | | otherwise = 154 | let st = A.index ary i 155 | st' = go h k x (s+bitsPerSubkey) st 156 | ary' = A.update ary i $! st' 157 | in BitmapIndexed b ary' 158 | where m = mask h s 159 | i = sparseIndex b m 160 | go h k x s (Full ary) = 161 | let st = A.index ary i 162 | st' = go h k x (s+bitsPerSubkey) st 163 | ary' = update16 ary i $! st' 164 | in Full ary' 165 | where i = index h s 166 | go h k x s t@(Collision hy v) 167 | | h == hy = Collision h (updateOrSnocWith f k x v) 168 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 169 | {-# INLINABLE insertWith #-} 170 | 171 | -- | In-place update version of insertWith 172 | unsafeInsertWith :: (v -> v -> v) -> Key -> v -> HashMap v -> HashMap v 173 | unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0) 174 | where 175 | h0 = hash k0 176 | go !h !k x !_ Empty = return $! leaf h k x 177 | go h k x s (Leaf hy l@(L ky y)) 178 | | hy == h = if ky == k 179 | then return $! leaf h k (f x y) 180 | else do 181 | let l' = x `seq` (L k x) 182 | return $! collision h l l' 183 | | otherwise = x `seq` two s h k x hy ky y 184 | go h k x s t@(BitmapIndexed b ary) 185 | | b .&. m == 0 = do 186 | ary' <- A.insertM ary i $! leaf h k x 187 | return $! bitmapIndexedOrFull (b .|. m) ary' 188 | | otherwise = do 189 | st <- A.indexM ary i 190 | st' <- go h k x (s+bitsPerSubkey) st 191 | A.unsafeUpdateM ary i st' 192 | return t 193 | where m = mask h s 194 | i = sparseIndex b m 195 | go h k x s t@(Full ary) = do 196 | st <- A.indexM ary i 197 | st' <- go h k x (s+bitsPerSubkey) st 198 | A.unsafeUpdateM ary i st' 199 | return t 200 | where i = index h s 201 | go h k x s t@(Collision hy v) 202 | | h == hy = return $! Collision h (updateOrSnocWith f k x v) 203 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 204 | 205 | -- | /O(log n)/ Adjust the value tied to a given key in this map only 206 | -- if it is present. Otherwise, leave the map alone. 207 | adjust :: (v -> v) -> Key -> HashMap v -> HashMap v 208 | adjust f k0 m0 = go h0 k0 0 m0 209 | where 210 | h0 = hash k0 211 | go !_ !_ !_ Empty = Empty 212 | go h k _ t@(Leaf hy (L ky y)) 213 | | hy == h && ky == k = leaf h k (f y) 214 | | otherwise = t 215 | go h k s t@(BitmapIndexed b ary) 216 | | b .&. m == 0 = t 217 | | otherwise = let st = A.index ary i 218 | st' = go h k (s+bitsPerSubkey) st 219 | ary' = A.update ary i $! st' 220 | in BitmapIndexed b ary' 221 | where m = mask h s 222 | i = sparseIndex b m 223 | go h k s (Full ary) = 224 | let i = index h s 225 | st = A.index ary i 226 | st' = go h k (s+bitsPerSubkey) st 227 | ary' = update16 ary i $! st' 228 | in Full ary' 229 | go h k _ t@(Collision hy v) 230 | | h == hy = Collision h (updateWith f k v) 231 | | otherwise = t 232 | 233 | -- | /O(log n)/ The expression (@'update' f k map@) updates the value @x@ at @k@, 234 | -- (if it is in the map). If (f k x) is @'Nothing', the element is deleted. 235 | -- If it is (@'Just' y), the key k is bound to the new value y. 236 | update :: (a -> Maybe a) -> Key -> HashMap a -> HashMap a 237 | update f = alter (>>= f) 238 | 239 | -- | /O(log n)/ The expression (@'alter' f k map@) alters the value @x@ at @k@, or 240 | -- absence thereof. @alter@ can be used to insert, delete, or update a value in a 241 | -- map. In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. 242 | alter :: (Maybe v -> Maybe v) -> Key -> HashMap v -> HashMap v 243 | alter f k m = 244 | case f (HM.lookup k m) of 245 | Nothing -> delete k m 246 | Just v -> insert k v m 247 | 248 | ------------------------------------------------------------------------ 249 | -- * Combine 250 | 251 | -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, 252 | -- the provided function (first argument) will be used to compute the result. 253 | unionWith :: (v -> v -> v) -> HashMap v -> HashMap v 254 | -> HashMap v 255 | unionWith f = unionWithKey (const f) 256 | {-# INLINE unionWith #-} 257 | 258 | -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, 259 | -- the provided function (first argument) will be used to compute the result. 260 | unionWithKey :: (Key -> v -> v -> v) -> HashMap v -> HashMap v -> HashMap v 261 | unionWithKey f = go 0 262 | where 263 | -- empty vs. anything 264 | go !_ t1 Empty = t1 265 | go _ Empty t2 = t2 266 | -- leaf vs. leaf 267 | go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) 268 | | h1 == h2 = if k1 == k2 269 | then leaf h1 k1 (f k1 v1 v2) 270 | else collision h1 l1 l2 271 | | otherwise = goDifferentHash s h1 h2 t1 t2 272 | go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) 273 | | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2) 274 | | otherwise = goDifferentHash s h1 h2 t1 t2 275 | go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) 276 | | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) 277 | | otherwise = goDifferentHash s h1 h2 t1 t2 278 | go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) 279 | | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2) 280 | | otherwise = goDifferentHash s h1 h2 t1 t2 281 | -- branch vs. branch 282 | go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = 283 | let b' = b1 .|. b2 284 | ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 285 | in bitmapIndexedOrFull b' ary' 286 | go s (BitmapIndexed b1 ary1) (Full ary2) = 287 | let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 288 | in Full ary' 289 | go s (Full ary1) (BitmapIndexed b2 ary2) = 290 | let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 291 | in Full ary' 292 | go s (Full ary1) (Full ary2) = 293 | let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask 294 | ary1 ary2 295 | in Full ary' 296 | -- leaf vs. branch 297 | go s (BitmapIndexed b1 ary1) t2 298 | | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 299 | b' = b1 .|. m2 300 | in bitmapIndexedOrFull b' ary' 301 | | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> 302 | go (s+bitsPerSubkey) st1 t2 303 | in BitmapIndexed b1 ary' 304 | where 305 | h2 = leafHashCode t2 306 | m2 = mask h2 s 307 | i = sparseIndex b1 m2 308 | go s t1 (BitmapIndexed b2 ary2) 309 | | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 310 | b' = b2 .|. m1 311 | in bitmapIndexedOrFull b' ary' 312 | | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> 313 | go (s+bitsPerSubkey) t1 st2 314 | in BitmapIndexed b2 ary' 315 | where 316 | h1 = leafHashCode t1 317 | m1 = mask h1 s 318 | i = sparseIndex b2 m1 319 | go s (Full ary1) t2 = 320 | let h2 = leafHashCode t2 321 | i = index h2 s 322 | ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 323 | in Full ary' 324 | go s t1 (Full ary2) = 325 | let h1 = leafHashCode t1 326 | i = index h1 s 327 | ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 328 | in Full ary' 329 | 330 | leafHashCode (Leaf h _) = h 331 | leafHashCode (Collision h _) = h 332 | leafHashCode _ = error "leafHashCode" 333 | 334 | goDifferentHash s h1 h2 t1 t2 335 | | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) 336 | | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) 337 | | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) 338 | where 339 | m1 = mask h1 s 340 | m2 = mask h2 s 341 | {-# INLINE unionWithKey #-} 342 | 343 | ------------------------------------------------------------------------ 344 | -- * Transformations 345 | 346 | -- | /O(n)/ Transform this map by applying a function to every value. 347 | mapWithKey :: (Key -> v1 -> v2) -> HashMap v1 -> HashMap v2 348 | mapWithKey f = go 349 | where 350 | go Empty = Empty 351 | go (Leaf h (L k v)) = leaf h k (f k v) 352 | go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary 353 | go (Full ary) = Full $ A.map' go ary 354 | go (Collision h ary) = 355 | Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary 356 | {-# INLINE mapWithKey #-} 357 | 358 | -- | /O(n)/ Transform this map by applying a function to every value. 359 | map :: (v1 -> v2) -> HashMap v1 -> HashMap v2 360 | map f = mapWithKey (const f) 361 | {-# INLINE map #-} 362 | 363 | 364 | ------------------------------------------------------------------------ 365 | -- * Filter 366 | 367 | -- | /O(n)/ Transform this map by applying a function to every value 368 | -- and retaining only some of them. 369 | mapMaybeWithKey :: (Key -> v1 -> Maybe v2) -> HashMap v1 -> HashMap v2 370 | mapMaybeWithKey f = filterMapAux onLeaf onColl 371 | where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v') 372 | onLeaf _ = Nothing 373 | 374 | onColl (L k v) | Just v' <- f k v = Just (L k v') 375 | | otherwise = Nothing 376 | {-# INLINE mapMaybeWithKey #-} 377 | 378 | -- | /O(n)/ Transform this map by applying a function to every value 379 | -- and retaining only some of them. 380 | mapMaybe :: (v1 -> Maybe v2) -> HashMap v1 -> HashMap v2 381 | mapMaybe f = mapMaybeWithKey (const f) 382 | {-# INLINE mapMaybe #-} 383 | 384 | 385 | -- TODO: Should we add a strict traverseWithKey? 386 | 387 | ------------------------------------------------------------------------ 388 | -- * Difference and intersection 389 | 390 | -- | /O(n*log m)/ Difference with a combining function. When two equal keys are 391 | -- encountered, the combining function is applied to the values of these keys. 392 | -- If it returns 'Nothing', the element is discarded (proper set difference). If 393 | -- it returns (@'Just' y@), the element is updated with a new value @y@. 394 | differenceWith :: (v -> w -> Maybe v) -> HashMap v -> HashMap w -> HashMap v 395 | differenceWith f a b = foldlWithKey' go empty a 396 | where 397 | go m k v = case HM.lookup k b of 398 | Nothing -> insert k v m 399 | Just w -> maybe m (\y -> insert k y m) (f v w) 400 | 401 | -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps 402 | -- the provided function is used to combine the values from the two 403 | -- maps. 404 | intersectionWith :: (v1 -> v2 -> v3) -> HashMap v1 -> HashMap v2 -> HashMap v3 405 | intersectionWith f a b = foldlWithKey' go empty a 406 | where 407 | go m k v = case HM.lookup k b of 408 | Just w -> insert k (f v w) m 409 | _ -> m 410 | 411 | -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps 412 | -- the provided function is used to combine the values from the two 413 | -- maps. 414 | intersectionWithKey :: (Key -> v1 -> v2 -> v3) -> HashMap v1 -> HashMap v2 -> HashMap v3 415 | intersectionWithKey f a b = foldlWithKey' go empty a 416 | where 417 | go m k v = case HM.lookup k b of 418 | Just w -> insert k (f k v w) m 419 | _ -> m 420 | {-# INLINABLE intersectionWithKey #-} 421 | 422 | ------------------------------------------------------------------------ 423 | -- ** Lists 424 | 425 | -- | /O(n*log n)/ Construct a map with the supplied mappings. If the 426 | -- list contains duplicate mappings, the later mappings take 427 | -- precedence. 428 | fromList :: [(Key, v)] -> HashMap v 429 | fromList = L.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) empty 430 | {-# INLINABLE fromList #-} 431 | 432 | -- | /O(n*log n)/ Construct a map from a list of elements. Uses 433 | -- the provided function f to merge duplicate entries (f newVal oldVal). 434 | -- 435 | -- For example: 436 | -- 437 | -- > fromListWith (+) [ (x, 1) | x <- xs ] 438 | -- 439 | -- will create a map with number of occurrences of each element in xs. 440 | -- 441 | -- > fromListWith (++) [ (k, [v]) | (k, v) <- xs ] 442 | -- 443 | -- will group all values by their keys in a list 'xs :: [(k, v)]' and 444 | -- return a 'HashMap k [v]'. 445 | fromListWith :: (v -> v -> v) -> [(Key, v)] -> HashMap v 446 | fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty 447 | {-# INLINE fromListWith #-} 448 | 449 | ------------------------------------------------------------------------ 450 | -- Array operations 451 | 452 | updateWith :: (v -> v) -> Key -> A.Array (Leaf v) -> A.Array (Leaf v) 453 | updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) 454 | where 455 | go !k !ary !i !n 456 | | i >= n = ary 457 | | otherwise = case A.index ary i of 458 | (L kx y) | k == kx -> let !v' = f y in A.update ary i (L k v') 459 | | otherwise -> go k ary (i+1) n 460 | {-# INLINABLE updateWith #-} 461 | 462 | -- | Append the given key and value to the array. If the key is 463 | -- already present, instead update the value of the key by applying 464 | -- the given function to the new and old value (in that order). The 465 | -- value is always evaluated to WHNF before being inserted into the 466 | -- array. 467 | updateOrSnocWith :: (v -> v -> v) -> Key -> v -> A.Array (Leaf v) -> A.Array (Leaf v) 468 | updateOrSnocWith f = updateOrSnocWithKey (const f) 469 | {-# INLINABLE updateOrSnocWith #-} 470 | 471 | -- | Append the given key and value to the array. If the key is 472 | -- already present, instead update the value of the key by applying 473 | -- the given function to the new and old value (in that order). The 474 | -- value is always evaluated to WHNF before being inserted into the 475 | -- array. 476 | updateOrSnocWithKey :: (Key -> v -> v -> v) -> Key -> v -> A.Array (Leaf v) -> A.Array (Leaf v) 477 | updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) 478 | where 479 | go !k v !ary !i !n 480 | | i >= n = A.run $ do 481 | -- Not found, append to the end. 482 | mary <- A.new_ (n + 1) 483 | A.copy ary 0 mary 0 n 484 | let !l = v `seq` (L k v) 485 | A.write mary n l 486 | return mary 487 | | otherwise = case A.index ary i of 488 | (L kx y) | k == kx -> let !v' = f k v y in A.update ary i (L k v') 489 | | otherwise -> go k v ary (i+1) n 490 | 491 | ------------------------------------------------------------------------ 492 | -- Smart constructors 493 | -- 494 | -- These constructors make sure the value is in WHNF before it's 495 | -- inserted into the constructor. 496 | 497 | leaf :: Hash -> Key -> v -> HashMap v 498 | leaf h k !v = Leaf h (L k v) 499 | {-# INLINE leaf #-} 500 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/src/HashSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | ------------------------------------------------------------------------ 7 | -- | 8 | -- Module : HashSet 9 | -- Copyright : 2011 Bryan O'Sullivan 10 | -- License : BSD-style 11 | -- Maintainer : johan.tibell@gmail.com 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- A set of /hashable/ values. A set cannot contain duplicate items. 16 | -- A 'HashSet' makes no guarantees as to the order of its elements. 17 | -- 18 | -- The implementation is based on /hash array mapped trie/. A 19 | -- 'HashSet' is often faster than other tree-based set types, 20 | -- especially when value comparison is expensive, as in the case of 21 | -- strings. 22 | -- 23 | -- Many operations have a average-case complexity of /O(log n)/. The 24 | -- implementation uses a large base (i.e. 16) so in practice these 25 | -- operations are constant time. 26 | 27 | module HashSet 28 | ( 29 | HashSet 30 | 31 | -- * Construction 32 | , empty 33 | , singleton 34 | 35 | -- * Combine 36 | , union 37 | , unions 38 | 39 | -- * Basic interface 40 | , null 41 | , size 42 | , member 43 | , insert 44 | , delete 45 | 46 | -- * Transformations 47 | , map 48 | 49 | -- * Difference and intersection 50 | , difference 51 | , intersection 52 | 53 | -- * Folds 54 | , foldl' 55 | , foldr 56 | 57 | -- * Filter 58 | , filter 59 | 60 | -- * Conversions 61 | 62 | -- ** Lists 63 | , toList 64 | , fromList 65 | 66 | -- * HashMaps 67 | , toMap 68 | , fromMap 69 | ) where 70 | 71 | import Control.DeepSeq (NFData(..)) 72 | import Data.Data hiding (Typeable) 73 | import Data.Hashable (Hashable(hashWithSalt)) 74 | import Data.Semigroup (Semigroup(..)) 75 | import GHC.Exts (build) 76 | import Prelude hiding (filter, foldr, map, null) 77 | import qualified Data.List as List 78 | import Text.Read 79 | import qualified GHC.Exts as Exts 80 | 81 | import qualified HashMap.Lazy as H 82 | import HashMap.Base (HashMap, foldrWithKey, equalKeys) 83 | 84 | import Key 85 | 86 | -- | A set of values. A set cannot contain duplicate values. 87 | newtype HashSet = HashSet { asMap :: HashMap () } 88 | 89 | instance NFData Key => NFData HashSet where 90 | rnf = rnf . asMap 91 | {-# INLINE rnf #-} 92 | 93 | instance Eq HashSet where 94 | HashSet a == HashSet b = equalKeys (==) a b 95 | {-# INLINE (==) #-} 96 | 97 | instance Ord Key => Ord HashSet where 98 | compare (HashSet a) (HashSet b) = compare a b 99 | {-# INLINE compare #-} 100 | 101 | instance Semigroup HashSet where 102 | (<>) = union 103 | {-# INLINE (<>) #-} 104 | 105 | instance Monoid HashSet where 106 | mempty = empty 107 | {-# INLINE mempty #-} 108 | mappend = (<>) 109 | {-# INLINE mappend #-} 110 | 111 | instance Read Key => Read HashSet where 112 | readPrec = parens $ prec 10 $ do 113 | Ident "fromList" <- lexP 114 | xs <- readPrec 115 | return (fromList xs) 116 | 117 | readListPrec = readListPrecDefault 118 | 119 | instance Show Key => Show HashSet where 120 | showsPrec d m = showParen (d > 10) $ 121 | showString "fromList " . shows (toList m) 122 | 123 | instance Data Key => Data HashSet where 124 | gfoldl f z m = z fromList `f` toList m 125 | toConstr _ = fromListConstr 126 | gunfold k z c = case constrIndex c of 127 | 1 -> k (z fromList) 128 | _ -> error "gunfold" 129 | dataTypeOf _ = hashSetDataType 130 | 131 | instance Hashable HashSet where 132 | hashWithSalt salt = hashWithSalt salt . asMap 133 | 134 | fromListConstr :: Constr 135 | fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix 136 | 137 | hashSetDataType :: DataType 138 | hashSetDataType = mkDataType "HashSet" [fromListConstr] 139 | 140 | -- | /O(1)/ Construct an empty set. 141 | empty :: HashSet 142 | empty = HashSet H.empty 143 | 144 | -- | /O(1)/ Construct a set with a single element. 145 | singleton :: Key -> HashSet 146 | singleton a = HashSet (H.singleton a ()) 147 | {-# INLINEABLE singleton #-} 148 | 149 | -- | /O(1)/ Convert to the equivalent 'HashMap'. 150 | toMap :: HashSet -> HashMap () 151 | toMap = asMap 152 | 153 | -- | /O(1)/ Convert from the equivalent 'HashMap'. 154 | fromMap :: HashMap () -> HashSet 155 | fromMap = HashSet 156 | 157 | -- | /O(n+m)/ Construct a set containing all elements from both sets. 158 | -- 159 | -- To obtain good performance, the smaller set must be presented as 160 | -- the first argument. 161 | union :: HashSet -> HashSet -> HashSet 162 | union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2) 163 | {-# INLINE union #-} 164 | 165 | -- TODO: Figure out the time complexity of 'unions'. 166 | 167 | -- | Construct a set containing all elements from a list of sets. 168 | unions :: [HashSet] -> HashSet 169 | unions = List.foldl' union empty 170 | {-# INLINE unions #-} 171 | 172 | -- | /O(1)/ Return 'True' if this set is empty, 'False' otherwise. 173 | null :: HashSet -> Bool 174 | null = H.null . asMap 175 | {-# INLINE null #-} 176 | 177 | -- | /O(n)/ Return the number of elements in this set. 178 | size :: HashSet -> Int 179 | size = H.size . asMap 180 | {-# INLINE size #-} 181 | 182 | -- | /O(log n)/ Return 'True' if the given value is present in this 183 | -- set, 'False' otherwise. 184 | member :: Key -> HashSet -> Bool 185 | member a s = case H.lookup a (asMap s) of 186 | Just _ -> True 187 | _ -> False 188 | {-# INLINABLE member #-} 189 | 190 | -- | /O(log n)/ Add the specified value to this set. 191 | insert :: Key -> HashSet -> HashSet 192 | insert a = HashSet . H.insert a () . asMap 193 | {-# INLINABLE insert #-} 194 | 195 | -- | /O(log n)/ Remove the specified value from this set if 196 | -- present. 197 | delete :: Key -> HashSet -> HashSet 198 | delete a = HashSet . H.delete a . asMap 199 | {-# INLINABLE delete #-} 200 | 201 | -- | /O(n)/ Transform this set by applying a function to every value. 202 | -- The resulting set may be smaller than the source. 203 | map :: (Key -> Key) -> HashSet -> HashSet 204 | map f = fromList . List.map f . toList 205 | {-# INLINE map #-} 206 | 207 | -- | /O(n)/ Difference of two sets. Return elements of the first set 208 | -- not existing in the second. 209 | difference :: HashSet -> HashSet -> HashSet 210 | difference (HashSet a) (HashSet b) = HashSet (H.difference a b) 211 | {-# INLINABLE difference #-} 212 | 213 | -- | /O(n)/ Intersection of two sets. Return elements present in both 214 | -- the first set and the second. 215 | intersection :: HashSet -> HashSet -> HashSet 216 | intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b) 217 | {-# INLINABLE intersection #-} 218 | 219 | -- | /O(n)/ Reduce this set by applying a binary operator to all 220 | -- elements, using the given starting value (typically the 221 | -- left-identity of the operator). Each application of the operator 222 | -- is evaluated before before using the result in the next 223 | -- application. This function is strict in the starting value. 224 | foldl' :: (a -> Key -> a) -> a -> HashSet -> a 225 | foldl' f z0 = H.foldlWithKey' g z0 . asMap 226 | where g z k _ = f z k 227 | {-# INLINE foldl' #-} 228 | 229 | -- | /O(n)/ Reduce this set by applying a binary operator to all 230 | -- elements, using the given starting value (typically the 231 | -- right-identity of the operator). 232 | foldr :: (Key -> a -> a) -> a -> HashSet -> a 233 | foldr f z0 = foldrWithKey g z0 . asMap 234 | where g k _ z = f k z 235 | {-# INLINE foldr #-} 236 | 237 | -- | /O(n)/ Filter this set by retaining only elements satisfying a 238 | -- predicate. 239 | filter :: (Key -> Bool) -> HashSet -> HashSet 240 | filter p = HashSet . H.filterWithKey q . asMap 241 | where q k _ = p k 242 | {-# INLINE filter #-} 243 | 244 | -- | /O(n)/ Return a list of this set's elements. The list is 245 | -- produced lazily. 246 | toList :: HashSet -> [Key] 247 | toList t = build (\ c z -> foldrWithKey ((const .) c) z (asMap t)) 248 | {-# INLINE toList #-} 249 | 250 | -- | /O(n*min(W, n))/ Construct a set from a list of elements. 251 | fromList :: [Key] -> HashSet 252 | fromList = HashSet . List.foldl' (\ m k -> H.insert k () m) H.empty 253 | {-# INLINE fromList #-} 254 | 255 | instance Exts.IsList HashSet where 256 | type Item HashSet = Key 257 | fromList = fromList 258 | toList = toList 259 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/src/Key.hsig: -------------------------------------------------------------------------------- 1 | signature Key where 2 | 3 | import Data.Hashable 4 | 5 | data Key 6 | instance Eq Key 7 | instance Hashable Key 8 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/unpacked-unordered-containers.cabal: -------------------------------------------------------------------------------- 1 | name: unpacked-unordered-containers 2 | category: Language 3 | version: 0 4 | license: BSD2 5 | license-file: LICENSE 6 | cabal-version: 2.0 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: experimental 10 | homepage: http://github.com/ekmett/unpacked-containers/ 11 | bug-reports: http://github.com/ekmett/unpacked-containers/issues 12 | copyright: Copyright (C) 2018 Edward A. Kmett 13 | build-type: Simple 14 | synopsis: Unpacked unordered containers via backpack 15 | description: This backpack mixin package supplies unpacked unordered sets and maps exploiting backpack's ability to unpack through signatures. 16 | extra-source-files: 17 | README.md 18 | CHANGELOG.md 19 | LICENSE 20 | 21 | source-repository head 22 | type: git 23 | location: git://github.com/ekmett/unpacked-containers.git 24 | 25 | library 26 | default-language: Haskell2010 27 | ghc-options: -Wall -O2 28 | hs-source-dirs: src 29 | signatures: 30 | Key 31 | 32 | exposed-modules: 33 | HashMap.Base 34 | HashMap.Lazy 35 | HashMap.Strict 36 | HashSet 37 | 38 | build-depends: 39 | base >= 4.10 && < 5, 40 | data-default-class ^>= 0.1, 41 | deepseq ^>= 1.4, 42 | hashable ^>= 1.2.7, 43 | ghc-prim, 44 | utils 45 | 46 | -- separate internal library to avoid recompiling these all the time 47 | library utils 48 | default-language: Haskell2010 49 | hs-source-dirs: utils 50 | ghc-options: -Wall -O2 51 | 52 | build-depends: 53 | base >= 4.10 && < 5, 54 | deepseq ^>= 1.4, 55 | ghc-prim 56 | 57 | exposed-modules: 58 | Internal.Array 59 | Internal.List 60 | Internal.UnsafeShift 61 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/utils/Internal/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-} 2 | {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} 3 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 4 | 5 | -- | Zero based arrays. 6 | -- 7 | -- Note that no bounds checking are performed. 8 | module Internal.Array 9 | ( Array 10 | , MArray 11 | 12 | -- * Creation 13 | , new 14 | , new_ 15 | , singleton 16 | , singletonM 17 | , pair 18 | 19 | -- * Basic interface 20 | , length 21 | , lengthM 22 | , read 23 | , write 24 | , index 25 | , indexM 26 | , update 27 | , updateWith' 28 | , unsafeUpdateM 29 | , insert 30 | , insertM 31 | , delete 32 | 33 | , unsafeFreeze 34 | , unsafeThaw 35 | , run 36 | , run2 37 | , copy 38 | , copyM 39 | 40 | -- * Folds 41 | , foldl' 42 | , foldr 43 | 44 | , thaw 45 | , map 46 | , map' 47 | , traverse 48 | , filter 49 | , toList 50 | ) where 51 | 52 | import qualified Data.Traversable as Traversable 53 | import Control.DeepSeq 54 | import GHC.Exts(Int(..)) 55 | import GHC.ST (ST(..)) 56 | 57 | import Prelude hiding (filter, foldr, length, map, read, traverse) 58 | 59 | import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#, 60 | indexSmallArray#, unsafeFreezeSmallArray#, unsafeThawSmallArray#, 61 | SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#, 62 | sizeofSmallMutableArray#, copySmallMutableArray#) 63 | 64 | import Control.Monad.ST (runST) 65 | 66 | type Array# a = SmallArray# a 67 | type MutableArray# a = SmallMutableArray# a 68 | 69 | newArray# = newSmallArray# 70 | readArray# = readSmallArray# 71 | writeArray# = writeSmallArray# 72 | indexArray# = indexSmallArray# 73 | unsafeFreezeArray# = unsafeFreezeSmallArray# 74 | unsafeThawArray# = unsafeThawSmallArray# 75 | sizeofArray# = sizeofSmallArray# 76 | copyArray# = copySmallArray# 77 | thawArray# = thawSmallArray# 78 | sizeofMutableArray# = sizeofSmallMutableArray# 79 | copyMutableArray# = copySmallMutableArray# 80 | 81 | ------------------------------------------------------------------------ 82 | 83 | data Array a = Array { 84 | unArray :: !(Array# a) 85 | } 86 | 87 | instance Show a => Show (Array a) where 88 | show = show . toList 89 | 90 | length :: Array a -> Int 91 | length ary = I# (sizeofArray# (unArray ary)) 92 | {-# INLINE length #-} 93 | 94 | -- | Smart constructor 95 | array :: Array# a -> Int -> Array a 96 | array ary _n = Array ary 97 | {-# INLINE array #-} 98 | 99 | data MArray s a = MArray { 100 | unMArray :: !(MutableArray# s a) 101 | } 102 | 103 | lengthM :: MArray s a -> Int 104 | lengthM mary = I# (sizeofMutableArray# (unMArray mary)) 105 | {-# INLINE lengthM #-} 106 | 107 | -- | Smart constructor 108 | marray :: MutableArray# s a -> Int -> MArray s a 109 | marray mary _n = MArray mary 110 | {-# INLINE marray #-} 111 | 112 | ------------------------------------------------------------------------ 113 | 114 | instance NFData a => NFData (Array a) where 115 | rnf = rnfArray 116 | 117 | rnfArray :: NFData a => Array a -> () 118 | rnfArray ary0 = go ary0 n0 0 119 | where 120 | n0 = length ary0 121 | go !ary !n !i 122 | | i >= n = () 123 | | otherwise = rnf (index ary i) `seq` go ary n (i+1) 124 | {-# INLINE rnfArray #-} 125 | 126 | -- | Create a new mutable array of specified size, in the specified 127 | -- state thread, with each element containing the specified initial 128 | -- value. 129 | new :: Int -> a -> ST s (MArray s a) 130 | new n@(I# n#) b = 131 | ST $ \s -> 132 | case newArray# n# b s of 133 | (# s', ary #) -> (# s', marray ary n #) 134 | {-# INLINE new #-} 135 | 136 | new_ :: Int -> ST s (MArray s a) 137 | new_ n = new n undefinedElem 138 | 139 | singleton :: a -> Array a 140 | singleton x = runST (singletonM x) 141 | {-# INLINE singleton #-} 142 | 143 | singletonM :: a -> ST s (Array a) 144 | singletonM x = new 1 x >>= unsafeFreeze 145 | {-# INLINE singletonM #-} 146 | 147 | pair :: a -> a -> Array a 148 | pair x y = run $ do 149 | ary <- new 2 x 150 | write ary 1 y 151 | return ary 152 | {-# INLINE pair #-} 153 | 154 | read :: MArray s a -> Int -> ST s a 155 | read ary _i@(I# i#) = ST $ \ s -> 156 | readArray# (unMArray ary) i# s 157 | {-# INLINE read #-} 158 | 159 | write :: MArray s a -> Int -> a -> ST s () 160 | write ary _i@(I# i#) b = ST $ \ s -> 161 | case writeArray# (unMArray ary) i# b s of 162 | s' -> (# s' , () #) 163 | {-# INLINE write #-} 164 | 165 | index :: Array a -> Int -> a 166 | index ary _i@(I# i#) = 167 | case indexArray# (unArray ary) i# of (# b #) -> b 168 | {-# INLINE index #-} 169 | 170 | indexM :: Array a -> Int -> ST s a 171 | indexM ary _i@(I# i#) = 172 | case indexArray# (unArray ary) i# of (# b #) -> return b 173 | {-# INLINE indexM #-} 174 | 175 | unsafeFreeze :: MArray s a -> ST s (Array a) 176 | unsafeFreeze mary 177 | = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of 178 | (# s', ary #) -> (# s', array ary (lengthM mary) #) 179 | {-# INLINE unsafeFreeze #-} 180 | 181 | unsafeThaw :: Array a -> ST s (MArray s a) 182 | unsafeThaw ary 183 | = ST $ \s -> case unsafeThawArray# (unArray ary) s of 184 | (# s', mary #) -> (# s', marray mary (length ary) #) 185 | {-# INLINE unsafeThaw #-} 186 | 187 | run :: (forall s . ST s (MArray s e)) -> Array e 188 | run act = runST $ act >>= unsafeFreeze 189 | {-# INLINE run #-} 190 | 191 | run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a) 192 | run2 k = runST (do 193 | (marr,b) <- k 194 | arr <- unsafeFreeze marr 195 | return (arr,b)) 196 | 197 | -- | Unsafely copy the elements of an array. Array bounds are not checked. 198 | copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () 199 | copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = 200 | ST $ \ s# -> 201 | case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of 202 | s2 -> (# s2, () #) 203 | 204 | -- | Unsafely copy the elements of an array. Array bounds are not checked. 205 | copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () 206 | copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = 207 | ST $ \ s# -> 208 | case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of 209 | s2 -> (# s2, () #) 210 | 211 | -- | /O(n)/ Insert an element at the given position in this array, 212 | -- increasing its size by one. 213 | insert :: Array e -> Int -> e -> Array e 214 | insert ary idx b = runST (insertM ary idx b) 215 | {-# INLINE insert #-} 216 | 217 | -- | /O(n)/ Insert an element at the given position in this array, 218 | -- increasing its size by one. 219 | insertM :: Array e -> Int -> e -> ST s (Array e) 220 | insertM ary idx b = 221 | do mary <- new_ (count+1) 222 | copy ary 0 mary 0 idx 223 | write mary idx b 224 | copy ary idx mary (idx+1) (count-idx) 225 | unsafeFreeze mary 226 | where !count = length ary 227 | {-# INLINE insertM #-} 228 | 229 | -- | /O(n)/ Update the element at the given position in this array. 230 | update :: Array e -> Int -> e -> Array e 231 | update ary idx b = runST (updateM ary idx b) 232 | {-# INLINE update #-} 233 | 234 | -- | /O(n)/ Update the element at the given position in this array. 235 | updateM :: Array e -> Int -> e -> ST s (Array e) 236 | updateM ary idx b = 237 | do mary <- thaw ary 0 count 238 | write mary idx b 239 | unsafeFreeze mary 240 | where !count = length ary 241 | {-# INLINE updateM #-} 242 | 243 | -- | /O(n)/ Update the element at the given positio in this array, by 244 | -- applying a function to it. Evaluates the element to WHNF before 245 | -- inserting it into the array. 246 | updateWith' :: Array e -> Int -> (e -> e) -> Array e 247 | updateWith' ary idx f = update ary idx $! f (index ary idx) 248 | {-# INLINE updateWith' #-} 249 | 250 | -- | /O(1)/ Update the element at the given position in this array, 251 | -- without copying. 252 | unsafeUpdateM :: Array e -> Int -> e -> ST s () 253 | unsafeUpdateM ary idx b = 254 | do mary <- unsafeThaw ary 255 | write mary idx b 256 | _ <- unsafeFreeze mary 257 | return () 258 | {-# INLINE unsafeUpdateM #-} 259 | 260 | foldl' :: (b -> a -> b) -> b -> Array a -> b 261 | foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 262 | where 263 | go ary n i !z 264 | | i >= n = z 265 | | otherwise = go ary n (i+1) (f z (index ary i)) 266 | {-# INLINE foldl' #-} 267 | 268 | foldr :: (a -> b -> b) -> b -> Array a -> b 269 | foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 270 | where 271 | go ary n i z 272 | | i >= n = z 273 | | otherwise = f (index ary i) (go ary n (i+1) z) 274 | {-# INLINE foldr #-} 275 | 276 | undefinedElem :: a 277 | undefinedElem = error "Data.HashMap.Array: Undefined element" 278 | {-# NOINLINE undefinedElem #-} 279 | 280 | thaw :: Array e -> Int -> Int -> ST s (MArray s e) 281 | thaw !ary !_o@(I# o#) !n@(I# n#) = 282 | ST $ \ s -> case thawArray# (unArray ary) o# n# s of 283 | (# s2, mary# #) -> (# s2, marray mary# n #) 284 | {-# INLINE thaw #-} 285 | 286 | -- | /O(n)/ Delete an element at the given position in this array, 287 | -- decreasing its size by one. 288 | delete :: Array e -> Int -> Array e 289 | delete ary idx = runST (deleteM ary idx) 290 | {-# INLINE delete #-} 291 | 292 | -- | /O(n)/ Delete an element at the given position in this array, 293 | -- decreasing its size by one. 294 | deleteM :: Array e -> Int -> ST s (Array e) 295 | deleteM ary idx = do 296 | do mary <- new_ (count-1) 297 | copy ary 0 mary 0 idx 298 | copy ary (idx+1) mary idx (count-(idx+1)) 299 | unsafeFreeze mary 300 | where !count = length ary 301 | {-# INLINE deleteM #-} 302 | 303 | map :: (a -> b) -> Array a -> Array b 304 | map f = \ ary -> 305 | let !n = length ary 306 | in run $ do 307 | mary <- new_ n 308 | go ary mary 0 n 309 | where 310 | go ary mary i n 311 | | i >= n = return mary 312 | | otherwise = do 313 | write mary i $ f (index ary i) 314 | go ary mary (i+1) n 315 | {-# INLINE map #-} 316 | 317 | -- | Strict version of 'map'. 318 | map' :: (a -> b) -> Array a -> Array b 319 | map' f = \ ary -> 320 | let !n = length ary 321 | in run $ do 322 | mary <- new_ n 323 | go ary mary 0 n 324 | where 325 | go ary mary i n 326 | | i >= n = return mary 327 | | otherwise = do 328 | write mary i $! f (index ary i) 329 | go ary mary (i+1) n 330 | {-# INLINE map' #-} 331 | 332 | fromList :: Int -> [a] -> Array a 333 | fromList n xs0 = 334 | run $ do 335 | mary <- new_ n 336 | go xs0 mary 0 337 | where 338 | go [] !mary !_ = return mary 339 | go (x:xs) mary i = do write mary i x 340 | go xs mary (i+1) 341 | 342 | toList :: Array a -> [a] 343 | toList = foldr (:) [] 344 | 345 | traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b) 346 | traverse f = \ ary -> fromList (length ary) `fmap` 347 | Traversable.traverse f (toList ary) 348 | {-# INLINE traverse #-} 349 | 350 | filter :: (a -> Bool) -> Array a -> Array a 351 | filter p = \ ary -> 352 | let !n = length ary 353 | in run $ do 354 | mary <- new_ n 355 | go ary mary 0 0 n 356 | where 357 | go ary mary i j n 358 | | i >= n = if i == j 359 | then return mary 360 | else do mary2 <- new_ j 361 | copyM mary 0 mary2 0 j 362 | return mary2 363 | | p el = write mary j el >> go ary mary (i+1) (j+1) n 364 | | otherwise = go ary mary (i+1) j n 365 | where el = index ary i 366 | {-# INLINE filter #-} 367 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/utils/Internal/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} 3 | -- | Extra list functions 4 | -- 5 | -- In separate module to aid testing. 6 | module Internal.List 7 | ( isPermutationBy 8 | , deleteBy 9 | , unorderedCompare 10 | ) where 11 | 12 | import Data.Maybe (fromMaybe) 13 | import Data.List (sortBy) 14 | import Data.Monoid 15 | import Prelude 16 | 17 | -- Note: previous implemenation isPermutation = null (as // bs) 18 | -- was O(n^2) too. 19 | -- 20 | -- This assumes lists are of equal length 21 | isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool 22 | isPermutationBy f = go 23 | where 24 | f' = flip f 25 | 26 | go [] [] = True 27 | go (x : xs) (y : ys) 28 | | f x y = go xs ys 29 | | otherwise = fromMaybe False $ do 30 | xs' <- deleteBy f' y xs 31 | ys' <- deleteBy f x ys 32 | return (go xs' ys') 33 | go [] (_ : _) = False 34 | go (_ : _) [] = False 35 | 36 | -- The idea: 37 | -- 38 | -- Homogeonous version 39 | -- 40 | -- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering 41 | -- uc c as bs = compare (sortBy c as) (sortBy c bs) 42 | -- 43 | -- But as we have only (a -> b -> Ordering), we cannot directly compare 44 | -- elements from the same list. 45 | -- 46 | -- So when comparing elements from the list, we count how many elements are 47 | -- "less and greater" in the other list, and use the count as a metric. 48 | -- 49 | unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering 50 | unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs) 51 | where 52 | go [] [] = EQ 53 | go [] (_ : _) = LT 54 | go (_ : _) [] = GT 55 | go (x : xs) (y : ys) = c x y `mappend` go xs ys 56 | 57 | cmpA a a' = compare (inB a) (inB a') 58 | cmpB b b' = compare (inA b) (inA b') 59 | 60 | inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs) 61 | inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as) 62 | 63 | -- Returns Nothing is nothing deleted 64 | deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b] 65 | deleteBy _ _ [] = Nothing 66 | deleteBy eq x (y:ys) = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys) 67 | -------------------------------------------------------------------------------- /unpacked-unordered-containers/utils/Internal/UnsafeShift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | module Internal.UnsafeShift 4 | ( unsafeShiftL 5 | , unsafeShiftR 6 | ) where 7 | 8 | import GHC.Exts (Word(W#), Int(I#), uncheckedShiftL#, uncheckedShiftRL#) 9 | 10 | unsafeShiftL :: Word -> Int -> Word 11 | unsafeShiftL (W# x#) (I# i#) = W# (x# `uncheckedShiftL#` i#) 12 | {-# INLINE unsafeShiftL #-} 13 | 14 | unsafeShiftR :: Word -> Int -> Word 15 | unsafeShiftR (W# x#) (I# i#) = W# (x# `uncheckedShiftRL#` i#) 16 | {-# INLINE unsafeShiftR #-} 17 | --------------------------------------------------------------------------------