unordered-containers-0.2.3.0/0000755000000000000000000000000012062470243014172 5ustar0000000000000000unordered-containers-0.2.3.0/LICENSE0000644000000000000000000000276212062470243015206 0ustar0000000000000000Copyright (c) 2010, Johan Tibell All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Johan Tibell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. unordered-containers-0.2.3.0/Setup.hs0000644000000000000000000000005612062470243015627 0ustar0000000000000000import Distribution.Simple main = defaultMain unordered-containers-0.2.3.0/unordered-containers.cabal0000644000000000000000000000753712062470243021324 0ustar0000000000000000name: unordered-containers version: 0.2.3.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been optimized for performance critical use, both in terms of large data quantities and high speed. . The declared cost of each operation is either worst-case or amortized, but remains valid even if structures are shared. license: BSD3 license-file: LICENSE author: Johan Tibell maintainer: johan.tibell@gmail.com Homepage: https://github.com/tibbe/unordered-containers bug-reports: https://github.com/tibbe/unordered-containers/issues copyright: 2010-2012 Johan Tibell 2010 Edward Z. Yang category: Data build-type: Simple cabal-version: >=1.8 flag debug description: Enable debug support default: False library exposed-modules: Data.HashMap.Lazy Data.HashMap.Strict Data.HashSet other-modules: Data.HashMap.Array Data.HashMap.Base Data.HashMap.PopCount Data.HashMap.Unsafe Data.HashMap.UnsafeShift build-depends: base >= 4 && < 5, deepseq >= 1.1, hashable >= 1.0.1.1 if impl(ghc < 7.4) c-sources: cbits/popc.c ghc-options: -Wall -O2 if impl(ghc >= 6.8) ghc-options: -fwarn-tabs if impl(ghc > 6.10) ghc-options: -fregs-graph if flag(debug) cpp-options: -DASSERTS test-suite hashmap-lazy-properties hs-source-dirs: tests main-is: HashMapProperties.hs type: exitcode-stdio-1.0 build-depends: base, containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS test-suite hashmap-strict-properties hs-source-dirs: tests main-is: HashMapProperties.hs type: exitcode-stdio-1.0 build-depends: base, containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS -DSTRICT test-suite hashset-properties hs-source-dirs: tests main-is: HashSetProperties.hs type: exitcode-stdio-1.0 build-depends: base, containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS test-suite regressions hs-source-dirs: tests main-is: Regressions.hs type: exitcode-stdio-1.0 build-depends: base, hashable >= 1.0.1.1, HUnit, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-hunit, test-framework-quickcheck2, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS test-suite strictness-properties hs-source-dirs: tests main-is: Strictness.hs type: exitcode-stdio-1.0 build-depends: base, ChasingBottoms, containers >= 0.4.2, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS benchmark benchmarks -- We cannot depend on the unordered-containers library directly as -- that creates a dependency cycle. hs-source-dirs: . benchmarks main-is: Benchmarks.hs type: exitcode-stdio-1.0 build-depends: base, bytestring, containers, criterion, deepseq >= 1.1, hashable >= 1.0.1.1, mtl, random if impl(ghc < 7.4) c-sources: cbits/popc.c ghc-options: -Wall -O2 -rtsopts if impl(ghc >= 6.8) ghc-options: -fwarn-tabs if impl(ghc > 6.10) ghc-options: -fregs-graph if flag(debug) cpp-options: -DASSERTS source-repository head type: git location: https://github.com/tibbe/unordered-containers.git unordered-containers-0.2.3.0/benchmarks/0000755000000000000000000000000012062470243016307 5ustar0000000000000000unordered-containers-0.2.3.0/benchmarks/Benchmarks.hs0000644000000000000000000002517212062470243020727 0ustar0000000000000000{-# LANGUAGE CPP, GADTs #-} module Main where import Control.DeepSeq import Control.Exception (evaluate) import Control.Monad.Trans (liftIO) import Criterion.Config import Criterion.Main import Data.Bits ((.&.)) import Data.Hashable (Hashable) import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IM import qualified Data.Map as M import Data.List (foldl') import Data.Maybe (fromMaybe) import Prelude hiding (lookup) import qualified Util.ByteString as UBS import qualified Util.Int as UI import qualified Util.String as US #if !MIN_VERSION_bytestring(0,10,0) instance NFData BS.ByteString #endif data B where B :: NFData a => a -> B instance NFData B where rnf (B b) = rnf b main :: IO () main = do let hm = HM.fromList elems :: HM.HashMap String Int hmbs = HM.fromList elemsBS :: HM.HashMap BS.ByteString Int hmi = HM.fromList elemsI :: HM.HashMap Int Int hmi2 = HM.fromList elemsI2 :: HM.HashMap Int Int m = M.fromList elems :: M.Map String Int mbs = M.fromList elemsBS :: M.Map BS.ByteString Int im = IM.fromList elemsI :: IM.IntMap Int defaultMainWith defaultConfig (liftIO . evaluate $ rnf [B m, B mbs, B hm, B hmbs, B hmi, B im]) [ -- * Comparison to other data structures -- ** Map bgroup "Map" [ bgroup "lookup" [ bench "String" $ whnf (lookupM keys) m , bench "ByteString" $ whnf (lookupM keysBS) mbs ] , bgroup "lookup-miss" [ bench "String" $ whnf (lookupM keys') m , bench "ByteString" $ whnf (lookupM keysBS') mbs ] , bgroup "insert" [ bench "String" $ whnf (insertM elems) M.empty , bench "ByteStringString" $ whnf (insertM elemsBS) M.empty ] , bgroup "insert-dup" [ bench "String" $ whnf (insertM elems) m , bench "ByteStringString" $ whnf (insertM elemsBS) mbs ] , bgroup "delete" [ bench "String" $ whnf (deleteM keys) m , bench "ByteString" $ whnf (deleteM keysBS) mbs ] , bgroup "delete-miss" [ bench "String" $ whnf (deleteM keys') m , bench "ByteString" $ whnf (deleteM keysBS') mbs ] , bgroup "size" [ bench "String" $ whnf M.size m , bench "ByteString" $ whnf M.size mbs ] , bgroup "fromList" [ bench "String" $ whnf M.fromList elems , bench "ByteString" $ whnf M.fromList elemsBS ] ] -- ** IntMap , bgroup "IntMap" [ bench "lookup" $ whnf (lookupIM keysI) im , bench "lookup-miss" $ whnf (lookupIM keysI') im , bench "insert" $ whnf (insertIM elemsI) IM.empty , bench "insert-dup" $ whnf (insertIM elemsI) im , bench "delete" $ whnf (deleteIM keysI) im , bench "delete-miss" $ whnf (deleteIM keysI') im , bench "size" $ whnf IM.size im , bench "fromList" $ whnf IM.fromList elemsI ] , bgroup "HashMap" [ -- * Basic interface bgroup "lookup" [ bench "String" $ whnf (lookup keys) hm , bench "ByteString" $ whnf (lookup keysBS) hmbs , bench "Int" $ whnf (lookup keysI) hmi ] , bgroup "lookup-miss" [ bench "String" $ whnf (lookup keys') hm , bench "ByteString" $ whnf (lookup keysBS') hmbs , bench "Int" $ whnf (lookup keysI') hmi ] , bgroup "insert" [ bench "String" $ whnf (insert elems) HM.empty , bench "ByteString" $ whnf (insert elemsBS) HM.empty , bench "Int" $ whnf (insert elemsI) HM.empty ] , bgroup "insert-dup" [ bench "String" $ whnf (insert elems) hm , bench "ByteString" $ whnf (insert elemsBS) hmbs , bench "Int" $ whnf (insert elemsI) hmi ] , bgroup "delete" [ bench "String" $ whnf (delete keys) hm , bench "ByteString" $ whnf (delete keysBS) hmbs , bench "Int" $ whnf (delete keysI) hmi ] , bgroup "delete-miss" [ bench "String" $ whnf (delete keys') hm , bench "ByteString" $ whnf (delete keysBS') hmbs , bench "Int" $ whnf (delete keysI') hmi ] -- Combine , bench "union" $ whnf (HM.union hmi) hmi2 -- Transformations , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi -- * Difference and intersection , bench "difference" $ whnf (HM.difference hmi) hmi2 , bench "intersection" $ whnf (HM.intersection hmi) hmi2 -- Folds , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi , bench "foldr" $ nf (HM.foldr (:) []) hmi -- Filter , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi -- Size , bgroup "size" [ bench "String" $ whnf HM.size hm , bench "ByteString" $ whnf HM.size hmbs , bench "Int" $ whnf HM.size hmi ] -- fromList , bgroup "fromList" [ bgroup name [ bgroup "long" [ bench "String" $ whnf fl1 elems , bench "ByteString" $ whnf fl2 elemsBS , bench "Int" $ whnf fl3 elemsI ] , bgroup "short" [ bench "String" $ whnf fl1 elemsDup , bench "ByteString" $ whnf fl2 elemsDupBS , bench "Int" $ whnf fl3 elemsDupI ] ] | (name,fl1,fl2,fl3) <- [("Base",HM.fromList,HM.fromList,HM.fromList) ,("insert",fromList_insert,fromList_insert,fromList_insert)] ] -- fromList , bgroup "fromListWith" [ bgroup name [ bgroup "long" [ bench "String" $ whnf (fl1 (+)) elems , bench "ByteString" $ whnf (fl2 (+)) elemsBS , bench "Int" $ whnf (fl3 (+)) elemsI ] , bgroup "short" [ bench "String" $ whnf (fl1 (+)) elemsDup , bench "ByteString" $ whnf (fl2 (+)) elemsDupBS , bench "Int" $ whnf (fl3 (+)) elemsDupI ] ] | (name,fl1,fl2,fl3) <- [("Base",HM.fromListWith,HM.fromListWith,HM.fromListWith) ,("insert",fromListWith_insert,fromListWith_insert,fromListWith_insert)] ] ] ] where n :: Int n = 2^(12 :: Int) elems = zip keys [1..n] keys = US.rnd 8 n elemsBS = zip keysBS [1..n] keysBS = UBS.rnd 8 n elemsI = zip keysI [1..n] keysI = UI.rnd (n+n) n elemsI2 = zip [n `div` 2..n + (n `div` 2)] [1..n] -- for union keys' = US.rnd' 8 n keysBS' = UBS.rnd' 8 n keysI' = UI.rnd' (n+n) n keysDup = US.rnd 2 n keysDupBS = UBS.rnd 2 n keysDupI = UI.rnd (n`div`4) n elemsDup = zip keysDup [1..n] elemsDupBS = zip keysDupBS [1..n] elemsDupI = zip keysDupI [1..n] ------------------------------------------------------------------------ -- * HashMap lookup :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> Int lookup xs m = foldl' (\z k -> fromMaybe z (HM.lookup k m)) 0 xs {-# SPECIALIZE lookup :: [Int] -> HM.HashMap Int Int -> Int #-} {-# SPECIALIZE lookup :: [String] -> HM.HashMap String Int -> Int #-} {-# SPECIALIZE lookup :: [BS.ByteString] -> HM.HashMap BS.ByteString Int -> Int #-} insert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k Int -> HM.HashMap k Int insert xs m0 = foldl' (\m (k, v) -> HM.insert k v m) m0 xs {-# SPECIALIZE insert :: [(Int, Int)] -> HM.HashMap Int Int -> HM.HashMap Int Int #-} {-# SPECIALIZE insert :: [(String, Int)] -> HM.HashMap String Int -> HM.HashMap String Int #-} {-# SPECIALIZE insert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} delete :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> HM.HashMap k Int delete xs m0 = foldl' (\m k -> HM.delete k m) m0 xs {-# SPECIALIZE delete :: [Int] -> HM.HashMap Int Int -> HM.HashMap Int Int #-} {-# SPECIALIZE delete :: [String] -> HM.HashMap String Int -> HM.HashMap String Int #-} {-# SPECIALIZE delete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} ------------------------------------------------------------------------ -- * Map lookupM :: Ord k => [k] -> M.Map k Int -> Int lookupM xs m = foldl' (\z k -> fromMaybe z (M.lookup k m)) 0 xs {-# SPECIALIZE lookupM :: [String] -> M.Map String Int -> Int #-} {-# SPECIALIZE lookupM :: [BS.ByteString] -> M.Map BS.ByteString Int -> Int #-} insertM :: Ord k => [(k, Int)] -> M.Map k Int -> M.Map k Int insertM xs m0 = foldl' (\m (k, v) -> M.insert k v m) m0 xs {-# SPECIALIZE insertM :: [(String, Int)] -> M.Map String Int -> M.Map String Int #-} {-# SPECIALIZE insertM :: [(BS.ByteString, Int)] -> M.Map BS.ByteString Int -> M.Map BS.ByteString Int #-} deleteM :: Ord k => [k] -> M.Map k Int -> M.Map k Int deleteM xs m0 = foldl' (\m k -> M.delete k m) m0 xs {-# SPECIALIZE deleteM :: [String] -> M.Map String Int -> M.Map String Int #-} {-# SPECIALIZE deleteM :: [BS.ByteString] -> M.Map BS.ByteString Int -> M.Map BS.ByteString Int #-} ------------------------------------------------------------------------ -- * IntMap lookupIM :: [Int] -> IM.IntMap Int -> Int lookupIM xs m = foldl' (\z k -> fromMaybe z (IM.lookup k m)) 0 xs insertIM :: [(Int, Int)] -> IM.IntMap Int -> IM.IntMap Int insertIM xs m0 = foldl' (\m (k, v) -> IM.insert k v m) m0 xs deleteIM :: [Int] -> IM.IntMap Int -> IM.IntMap Int deleteIM xs m0 = foldl' (\m k -> IM.delete k m) m0 xs ------------------------------------------------------------------------ -- * Reference implementations fromList_insert :: (Eq k, Hashable k) => [(k, v)] -> HM.HashMap k v fromList_insert = foldl' (\ m (k, v) -> HM.insert k v m) HM.empty #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList_insert #-} #endif fromListWith_insert :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HM.HashMap k v fromListWith_insert f = foldl' (\ m (k, v) -> HM.insertWith f k v m) HM.empty #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromListWith_insert #-} #endif unordered-containers-0.2.3.0/cbits/0000755000000000000000000000000012062470243015276 5ustar0000000000000000unordered-containers-0.2.3.0/cbits/popc.c0000644000000000000000000000720012062470243016402 0ustar0000000000000000#include /* Cribbed from http://wiki.cs.pdx.edu/forge/popcount.html */ static char popcount_table_8[256] = { /*0*/ 0, /*1*/ 1, /*2*/ 1, /*3*/ 2, /*4*/ 1, /*5*/ 2, /*6*/ 2, /*7*/ 3, /*8*/ 1, /*9*/ 2, /*10*/ 2, /*11*/ 3, /*12*/ 2, /*13*/ 3, /*14*/ 3, /*15*/ 4, /*16*/ 1, /*17*/ 2, /*18*/ 2, /*19*/ 3, /*20*/ 2, /*21*/ 3, /*22*/ 3, /*23*/ 4, /*24*/ 2, /*25*/ 3, /*26*/ 3, /*27*/ 4, /*28*/ 3, /*29*/ 4, /*30*/ 4, /*31*/ 5, /*32*/ 1, /*33*/ 2, /*34*/ 2, /*35*/ 3, /*36*/ 2, /*37*/ 3, /*38*/ 3, /*39*/ 4, /*40*/ 2, /*41*/ 3, /*42*/ 3, /*43*/ 4, /*44*/ 3, /*45*/ 4, /*46*/ 4, /*47*/ 5, /*48*/ 2, /*49*/ 3, /*50*/ 3, /*51*/ 4, /*52*/ 3, /*53*/ 4, /*54*/ 4, /*55*/ 5, /*56*/ 3, /*57*/ 4, /*58*/ 4, /*59*/ 5, /*60*/ 4, /*61*/ 5, /*62*/ 5, /*63*/ 6, /*64*/ 1, /*65*/ 2, /*66*/ 2, /*67*/ 3, /*68*/ 2, /*69*/ 3, /*70*/ 3, /*71*/ 4, /*72*/ 2, /*73*/ 3, /*74*/ 3, /*75*/ 4, /*76*/ 3, /*77*/ 4, /*78*/ 4, /*79*/ 5, /*80*/ 2, /*81*/ 3, /*82*/ 3, /*83*/ 4, /*84*/ 3, /*85*/ 4, /*86*/ 4, /*87*/ 5, /*88*/ 3, /*89*/ 4, /*90*/ 4, /*91*/ 5, /*92*/ 4, /*93*/ 5, /*94*/ 5, /*95*/ 6, /*96*/ 2, /*97*/ 3, /*98*/ 3, /*99*/ 4, /*100*/ 3, /*101*/ 4, /*102*/ 4, /*103*/ 5, /*104*/ 3, /*105*/ 4, /*106*/ 4, /*107*/ 5, /*108*/ 4, /*109*/ 5, /*110*/ 5, /*111*/ 6, /*112*/ 3, /*113*/ 4, /*114*/ 4, /*115*/ 5, /*116*/ 4, /*117*/ 5, /*118*/ 5, /*119*/ 6, /*120*/ 4, /*121*/ 5, /*122*/ 5, /*123*/ 6, /*124*/ 5, /*125*/ 6, /*126*/ 6, /*127*/ 7, /*128*/ 1, /*129*/ 2, /*130*/ 2, /*131*/ 3, /*132*/ 2, /*133*/ 3, /*134*/ 3, /*135*/ 4, /*136*/ 2, /*137*/ 3, /*138*/ 3, /*139*/ 4, /*140*/ 3, /*141*/ 4, /*142*/ 4, /*143*/ 5, /*144*/ 2, /*145*/ 3, /*146*/ 3, /*147*/ 4, /*148*/ 3, /*149*/ 4, /*150*/ 4, /*151*/ 5, /*152*/ 3, /*153*/ 4, /*154*/ 4, /*155*/ 5, /*156*/ 4, /*157*/ 5, /*158*/ 5, /*159*/ 6, /*160*/ 2, /*161*/ 3, /*162*/ 3, /*163*/ 4, /*164*/ 3, /*165*/ 4, /*166*/ 4, /*167*/ 5, /*168*/ 3, /*169*/ 4, /*170*/ 4, /*171*/ 5, /*172*/ 4, /*173*/ 5, /*174*/ 5, /*175*/ 6, /*176*/ 3, /*177*/ 4, /*178*/ 4, /*179*/ 5, /*180*/ 4, /*181*/ 5, /*182*/ 5, /*183*/ 6, /*184*/ 4, /*185*/ 5, /*186*/ 5, /*187*/ 6, /*188*/ 5, /*189*/ 6, /*190*/ 6, /*191*/ 7, /*192*/ 2, /*193*/ 3, /*194*/ 3, /*195*/ 4, /*196*/ 3, /*197*/ 4, /*198*/ 4, /*199*/ 5, /*200*/ 3, /*201*/ 4, /*202*/ 4, /*203*/ 5, /*204*/ 4, /*205*/ 5, /*206*/ 5, /*207*/ 6, /*208*/ 3, /*209*/ 4, /*210*/ 4, /*211*/ 5, /*212*/ 4, /*213*/ 5, /*214*/ 5, /*215*/ 6, /*216*/ 4, /*217*/ 5, /*218*/ 5, /*219*/ 6, /*220*/ 5, /*221*/ 6, /*222*/ 6, /*223*/ 7, /*224*/ 3, /*225*/ 4, /*226*/ 4, /*227*/ 5, /*228*/ 4, /*229*/ 5, /*230*/ 5, /*231*/ 6, /*232*/ 4, /*233*/ 5, /*234*/ 5, /*235*/ 6, /*236*/ 5, /*237*/ 6, /*238*/ 6, /*239*/ 7, /*240*/ 4, /*241*/ 5, /*242*/ 5, /*243*/ 6, /*244*/ 5, /*245*/ 6, /*246*/ 6, /*247*/ 7, /*248*/ 5, /*249*/ 6, /*250*/ 6, /*251*/ 7, /*252*/ 6, /*253*/ 7, /*254*/ 7, /*255*/ 8, }; /* Table-driven popcount, with 8-bit tables */ /* 6 ops plus 4 casts and 4 lookups, 0 long immediates, 4 stages */ inline uint32_t popcount(uint32_t x) { return popcount_table_8[(uint8_t)x] + popcount_table_8[(uint8_t)(x >> 8)] + popcount_table_8[(uint8_t)(x >> 16)] + popcount_table_8[(uint8_t)(x >> 24)]; } /* TODO: Add a 16-bit variant */ unordered-containers-0.2.3.0/Data/0000755000000000000000000000000012062470243015043 5ustar0000000000000000unordered-containers-0.2.3.0/Data/HashSet.hs0000644000000000000000000001620512062470243016742 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable #-} ------------------------------------------------------------------------ -- | -- Module : Data.HashSet -- Copyright : 2011 Bryan O'Sullivan -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional -- Portability : portable -- -- A set of /hashable/ values. A set cannot contain duplicate items. -- A 'HashSet' makes no guarantees as to the order of its elements. -- -- The implementation is based on /hash array mapped trie/. A -- 'HashSet' is often faster than other tree-based set types, -- especially when value comparison is expensive, as in the case of -- strings. -- -- Many operations have a average-case complexity of /O(log n)/. The -- implementation uses a large base (i.e. 16) so in practice these -- operations are constant time. module Data.HashSet ( HashSet -- * Construction , empty , singleton -- * Combine , union , unions -- * Basic interface , null , size , member , insert , delete -- * Transformations , map -- * Difference and intersection , difference , intersection -- * Folds , foldl' , foldr -- * Filter , filter -- ** Lists , toList , fromList ) where import Control.DeepSeq (NFData(..)) import Data.HashMap.Base (HashMap, foldrWithKey) import Data.Hashable (Hashable) import Data.Monoid (Monoid(..)) import Prelude hiding (filter, foldr, map, null) import qualified Data.Foldable as Foldable import qualified Data.HashMap.Lazy as H import qualified Data.List as List import Data.Typeable (Typeable) #if defined(__GLASGOW_HASKELL__) import Data.Data hiding (Typeable) import GHC.Exts (build) #endif -- | A set of values. A set cannot contain duplicate values. newtype HashSet a = HashSet { asMap :: HashMap a () } deriving (Typeable) instance (NFData a) => NFData (HashSet a) where rnf = rnf . asMap {-# INLINE rnf #-} instance (Hashable a, Eq a) => Eq (HashSet a) where -- This performs two passes over the tree. a == b = foldr f True b && size a == size b where f i = (&& i `member` a) {-# INLINE (==) #-} instance Foldable.Foldable HashSet where foldr = Data.HashSet.foldr {-# INLINE foldr #-} instance (Hashable a, Eq a) => Monoid (HashSet a) where mempty = empty {-# INLINE mempty #-} mappend = union {-# INLINE mappend #-} instance (Show a) => Show (HashSet a) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) #if __GLASGOW_HASKELL__ instance (Data a, Eq a, Hashable a) => Data (HashSet a) where gfoldl f z m = z fromList `f` toList m toConstr _ = fromListConstr gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashSetDataType dataCast1 f = gcast1 f fromListConstr :: Constr fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix hashSetDataType :: DataType hashSetDataType = mkDataType "Data.HashSet" [fromListConstr] #endif -- | /O(1)/ Construct an empty set. empty :: HashSet a empty = HashSet H.empty -- | /O(1)/ Construct a set with a single element. singleton :: Hashable a => a -> HashSet a singleton a = HashSet (H.singleton a ()) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE singleton #-} #endif -- | /O(n+m)/ Construct a set containing all elements from both sets. -- -- To obtain good performance, the smaller set must be presented as -- the first argument. union :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2) {-# INLINE union #-} -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets. unions :: (Eq a, Hashable a) => [HashSet a] -> HashSet a unions = List.foldl' union empty {-# INLINE unions #-} -- | /O(1)/ Return 'True' if this set is empty, 'False' otherwise. null :: HashSet a -> Bool null = H.null . asMap {-# INLINE null #-} -- | /O(n)/ Return the number of elements in this set. size :: HashSet a -> Int size = H.size . asMap {-# INLINE size #-} -- | /O(min(n,W))/ Return 'True' if the given value is present in this -- set, 'False' otherwise. member :: (Eq a, Hashable a) => a -> HashSet a -> Bool member a s = case H.lookup a (asMap s) of Just _ -> True _ -> False #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE member #-} #endif -- | /O(min(n,W))/ Add the specified value to this set. insert :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a insert a = HashSet . H.insert a () . asMap #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #endif -- | /O(min(n,W))/ Remove the specified value from this set if -- present. delete :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a delete a = HashSet . H.delete a . asMap #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE delete #-} #endif -- | /O(n)/ Transform this set by applying a function to every value. -- The resulting set may be smaller than the source. map :: (Hashable b, Eq b) => (a -> b) -> HashSet a -> HashSet b map f = fromList . List.map f . toList {-# INLINE map #-} -- | /O(n)/ Difference of two sets. Return elements of the first set -- not existing in the second. difference :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a difference (HashSet a) (HashSet b) = HashSet (H.difference a b) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE difference #-} #endif -- | /O(n)/ Intersection of two sets. Return elements present in both -- the first set and the second. intersection :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersection #-} #endif -- | /O(n)/ Reduce this set by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). Each application of the operator -- is evaluated before before using the result in the next -- application. This function is strict in the starting value. foldl' :: (a -> b -> a) -> a -> HashSet b -> a foldl' f z0 = H.foldlWithKey' g z0 . asMap where g z k _ = f z k {-# INLINE foldl' #-} -- | /O(n)/ Reduce this set by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). foldr :: (b -> a -> a) -> a -> HashSet b -> a foldr f z0 = foldrWithKey g z0 . asMap where g k _ z = f k z {-# INLINE foldr #-} -- | /O(n)/ Filter this set by retaining only elements satisfying a -- predicate. filter :: (a -> Bool) -> HashSet a -> HashSet a filter p = HashSet . H.filterWithKey q . asMap where q k _ = p k {-# INLINE filter #-} -- | /O(n)/ Return a list of this set's elements. The list is -- produced lazily. toList :: HashSet a -> [a] #if defined(__GLASGOW_HASKELL__) toList t = build (\ c z -> foldrWithKey ((const .) c) z (asMap t)) #else toList = foldrWithKey (\ k _ xs -> k : xs) [] . asMap #endif {-# INLINE toList #-} -- | /O(n*min(W, n))/ Construct a set from a list of elements. fromList :: (Eq a, Hashable a) => [a] -> HashSet a fromList = HashSet . List.foldl' (\ m k -> H.insert k () m) H.empty {-# INLINE fromList #-} unordered-containers-0.2.3.0/Data/HashMap/0000755000000000000000000000000012062470243016364 5ustar0000000000000000unordered-containers-0.2.3.0/Data/HashMap/Array.hs0000644000000000000000000003035112062470243020000 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} -- | Zero based arrays. -- -- Note that no bounds checking are performed. module Data.HashMap.Array ( Array , MArray -- * Creation , new , new_ , singleton , singletonM , pair -- * Basic interface , length , lengthM , read , write , index , indexM , update , updateWith' , unsafeUpdateM , insert , insertM , delete , unsafeFreeze , unsafeThaw , run , run2 , copy , copyM -- * Folds , foldl' , foldr , thaw , map , map' , traverse , filter , toList ) where import qualified Data.Traversable as Traversable import Control.Applicative (Applicative) import Control.DeepSeq import Control.Monad.ST hiding (runST) import GHC.Exts import GHC.ST (ST(..)) import Prelude hiding (filter, foldr, length, map, read) import qualified Prelude import Data.HashMap.Unsafe (runST) ------------------------------------------------------------------------ #if defined(ASSERTS) -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek! # define CHECK_BOUNDS(_func_,_len_,_k_) \ if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \ if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else # define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_) # define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_) # define CHECK_EQ(_func_,_lhs_,_rhs_) CHECK_OP(_func_,==,_lhs_,_rhs_) #else # define CHECK_BOUNDS(_func_,_len_,_k_) # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) # define CHECK_GT(_func_,_lhs_,_rhs_) # define CHECK_LE(_func_,_lhs_,_rhs_) # define CHECK_EQ(_func_,_lhs_,_rhs_) #endif data Array a = Array { unArray :: !(Array# a) #if __GLASGOW_HASKELL__ < 702 , length :: !Int #endif } instance Show a => Show (Array a) where show = show . toList #if __GLASGOW_HASKELL__ >= 702 length :: Array a -> Int length ary = I# (sizeofArray# (unArray ary)) {-# INLINE length #-} #endif -- | Smart constructor array :: Array# a -> Int -> Array a #if __GLASGOW_HASKELL__ >= 702 array ary _n = Array ary #else array = Array #endif {-# INLINE array #-} data MArray s a = MArray { unMArray :: !(MutableArray# s a) #if __GLASGOW_HASKELL__ < 702 , lengthM :: !Int #endif } #if __GLASGOW_HASKELL__ >= 702 lengthM :: MArray s a -> Int lengthM mary = I# (sizeofMutableArray# (unMArray mary)) {-# INLINE lengthM #-} #endif -- | Smart constructor marray :: MutableArray# s a -> Int -> MArray s a #if __GLASGOW_HASKELL__ >= 702 marray mary _n = MArray mary #else marray = MArray #endif {-# INLINE marray #-} ------------------------------------------------------------------------ instance NFData a => NFData (Array a) where rnf = rnfArray rnfArray :: NFData a => Array a -> () rnfArray ary0 = go ary0 n0 0 where n0 = length ary0 go !ary !n !i | i >= n = () | otherwise = rnf (index ary i) `seq` go ary n (i+1) {-# INLINE rnfArray #-} -- | Create a new mutable array of specified size, in the specified -- state thread, with each element containing the specified initial -- value. new :: Int -> a -> ST s (MArray s a) new n@(I# n#) b = CHECK_GT("new",n,(0 :: Int)) ST $ \s -> case newArray# n# b s of (# s', ary #) -> (# s', marray ary n #) {-# INLINE new #-} new_ :: Int -> ST s (MArray s a) new_ n = new n undefinedElem singleton :: a -> Array a singleton x = runST (singletonM x) {-# INLINE singleton #-} singletonM :: a -> ST s (Array a) singletonM x = new 1 x >>= unsafeFreeze {-# INLINE singletonM #-} pair :: a -> a -> Array a pair x y = run $ do ary <- new 2 x write ary 1 y return ary {-# INLINE pair #-} read :: MArray s a -> Int -> ST s a read ary _i@(I# i#) = ST $ \ s -> CHECK_BOUNDS("read", lengthM ary, _i) readArray# (unMArray ary) i# s {-# INLINE read #-} write :: MArray s a -> Int -> a -> ST s () write ary _i@(I# i#) b = ST $ \ s -> CHECK_BOUNDS("write", lengthM ary, _i) case writeArray# (unMArray ary) i# b s of s' -> (# s' , () #) {-# INLINE write #-} index :: Array a -> Int -> a index ary _i@(I# i#) = CHECK_BOUNDS("index", length ary, _i) case indexArray# (unArray ary) i# of (# b #) -> b {-# INLINE index #-} indexM :: Array a -> Int -> ST s a indexM ary _i@(I# i#) = CHECK_BOUNDS("indexM", length ary, _i) case indexArray# (unArray ary) i# of (# b #) -> return b {-# INLINE indexM #-} unsafeFreeze :: MArray s a -> ST s (Array a) unsafeFreeze mary = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of (# s', ary #) -> (# s', array ary (lengthM mary) #) {-# INLINE unsafeFreeze #-} unsafeThaw :: Array a -> ST s (MArray s a) unsafeThaw ary = ST $ \s -> case unsafeThawArray# (unArray ary) s of (# s', mary #) -> (# s', marray mary (length ary) #) {-# INLINE unsafeThaw #-} run :: (forall s . ST s (MArray s e)) -> Array e run act = runST $ act >>= unsafeFreeze {-# INLINE run #-} run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a) run2 k = runST (do (marr,b) <- k arr <- unsafeFreeze marr return (arr,b)) -- | Unsafely copy the elements of an array. Array bounds are not checked. copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () #if __GLASGOW_HASKELL__ >= 702 copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = CHECK_LE("copy", _sidx + _n, length src) CHECK_LE("copy", _didx + _n, lengthM dst) ST $ \ s# -> case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) #else copy !src !sidx !dst !didx n = CHECK_LE("copy", sidx + n, length src) CHECK_LE("copy", didx + n, lengthM dst) copy_loop sidx didx 0 where copy_loop !i !j !c | c >= n = return () | otherwise = do b <- indexM src i write dst j b copy_loop (i+1) (j+1) (c+1) #endif -- | Unsafely copy the elements of an array. Array bounds are not checked. copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () #if __GLASGOW_HASKELL__ >= 702 copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1) CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) ST $ \ s# -> case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) #else copyM !src !sidx !dst !didx n = CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1) CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1) copy_loop sidx didx 0 where copy_loop !i !j !c | c >= n = return () | otherwise = do b <- read src i write dst j b copy_loop (i+1) (j+1) (c+1) #endif -- | /O(n)/ Insert an element at the given position in this array, -- increasing its size by one. insert :: Array e -> Int -> e -> Array e insert ary idx b = runST (insertM ary idx b) {-# INLINE insert #-} -- | /O(n)/ Insert an element at the given position in this array, -- increasing its size by one. insertM :: Array e -> Int -> e -> ST s (Array e) insertM ary idx b = CHECK_BOUNDS("insertM", count + 1, idx) do mary <- new_ (count+1) copy ary 0 mary 0 idx write mary idx b copy ary idx mary (idx+1) (count-idx) unsafeFreeze mary where !count = length ary {-# INLINE insertM #-} -- | /O(n)/ Update the element at the given position in this array. update :: Array e -> Int -> e -> Array e update ary idx b = runST (updateM ary idx b) {-# INLINE update #-} -- | /O(n)/ Update the element at the given position in this array. updateM :: Array e -> Int -> e -> ST s (Array e) updateM ary idx b = CHECK_BOUNDS("updateM", count, idx) do mary <- thaw ary 0 count write mary idx b unsafeFreeze mary where !count = length ary {-# INLINE updateM #-} -- | /O(n)/ Update the element at the given positio in this array, by -- applying a function to it. Evaluates the element to WHNF before -- inserting it into the array. updateWith' :: Array e -> Int -> (e -> e) -> Array e updateWith' ary idx f = update ary idx $! f (index ary idx) {-# INLINE updateWith' #-} -- | /O(1)/ Update the element at the given position in this array, -- without copying. unsafeUpdateM :: Array e -> Int -> e -> ST s () unsafeUpdateM ary idx b = CHECK_BOUNDS("unsafeUpdateM", length ary, idx) do mary <- unsafeThaw ary write mary idx b _ <- unsafeFreeze mary return () {-# INLINE unsafeUpdateM #-} foldl' :: (b -> a -> b) -> b -> Array a -> b foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where go ary n i !z | i >= n = z | otherwise = go ary n (i+1) (f z (index ary i)) {-# INLINE foldl' #-} foldr :: (a -> b -> b) -> b -> Array a -> b foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where go ary n i z | i >= n = z | otherwise = f (index ary i) (go ary n (i+1) z) {-# INLINE foldr #-} undefinedElem :: a undefinedElem = error "Data.HashMap.Array: Undefined element" {-# NOINLINE undefinedElem #-} thaw :: Array e -> Int -> Int -> ST s (MArray s e) #if __GLASGOW_HASKELL__ >= 702 thaw !ary !_o@(I# o#) !n@(I# n#) = CHECK_LE("thaw", _o + n, length ary) ST $ \ s -> case thawArray# (unArray ary) o# n# s of (# s2, mary# #) -> (# s2, marray mary# n #) #else thaw !ary !o !n = CHECK_LE("thaw", o + n, length ary) do mary <- new_ n copy ary o mary 0 n return mary #endif {-# INLINE thaw #-} -- | /O(n)/ Delete an element at the given position in this array, -- decreasing its size by one. delete :: Array e -> Int -> Array e delete ary idx = runST (deleteM ary idx) {-# INLINE delete #-} -- | /O(n)/ Delete an element at the given position in this array, -- decreasing its size by one. deleteM :: Array e -> Int -> ST s (Array e) deleteM ary idx = do CHECK_BOUNDS("deleteM", count, idx) do mary <- new_ (count-1) copy ary 0 mary 0 idx copy ary (idx+1) mary idx (count-(idx+1)) unsafeFreeze mary where !count = length ary {-# INLINE deleteM #-} map :: (a -> b) -> Array a -> Array b map f = \ ary -> let !n = length ary in run $ do mary <- new_ n go ary mary 0 n where go ary mary i n | i >= n = return mary | otherwise = do write mary i $ f (index ary i) go ary mary (i+1) n {-# INLINE map #-} -- | Strict version of 'map'. map' :: (a -> b) -> Array a -> Array b map' f = \ ary -> let !n = length ary in run $ do mary <- new_ n go ary mary 0 n where go ary mary i n | i >= n = return mary | otherwise = do write mary i $! f (index ary i) go ary mary (i+1) n {-# INLINE map' #-} fromList :: Int -> [a] -> Array a fromList n xs0 = CHECK_EQ("fromList", n, Prelude.length xs0) run $ do mary <- new_ n go xs0 mary 0 where go [] !mary !_ = return mary go (x:xs) mary i = do write mary i x go xs mary (i+1) toList :: Array a -> [a] toList = foldr (:) [] traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b) traverse f = \ ary -> fromList (length ary) `fmap` Traversable.traverse f (toList ary) {-# INLINE traverse #-} filter :: (a -> Bool) -> Array a -> Array a filter p = \ ary -> let !n = length ary in run $ do mary <- new_ n go ary mary 0 0 n where go ary mary i j n | i >= n = if i == j then return mary else do mary2 <- new_ j copyM mary 0 mary2 0 j return mary2 | p el = write mary j el >> go ary mary (i+1) (j+1) n | otherwise = go ary mary (i+1) j n where el = index ary i {-# INLINE filter #-} unordered-containers-0.2.3.0/Data/HashMap/Base.hs0000644000000000000000000011457312062470243017605 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} module Data.HashMap.Base ( HashMap(..) , Leaf(..) -- * Construction , empty , singleton -- * Basic interface , null , size , member , lookup , lookupDefault , (!) , insert , insertWith , unsafeInsert , delete , adjust -- * Combine -- ** Union , union , unionWith , unions -- * Transformations , map , traverseWithKey -- * Difference and intersection , difference , intersection , intersectionWith -- * Folds , foldl' , foldlWithKey' , foldr , foldrWithKey -- * Filter , filter , filterWithKey -- * Conversions , keys , elems -- ** Lists , toList , fromList , fromListWith -- Internals used by the strict version , Bitmap , bitmapIndexedOrFull , collision , hash , mask , index , bitsPerSubkey , fullNodeMask , sparseIndex , two , unionArrayBy , update16 , update16M , update16With' , updateOrConcatWith ) where import Control.Applicative ((<$>), Applicative(pure)) import Control.DeepSeq (NFData(rnf)) import Control.Monad.ST (ST) import Data.Bits ((.&.), (.|.), complement) import qualified Data.Foldable as Foldable import qualified Data.List as L import Data.Monoid (Monoid(mempty, mappend)) import Data.Traversable (Traversable(..)) import Data.Word (Word) import Prelude hiding (filter, foldr, lookup, map, null, pred) import qualified Data.HashMap.Array as A import qualified Data.Hashable as H import Data.Hashable (Hashable) import Data.HashMap.PopCount (popCount) import Data.HashMap.Unsafe (runST) import Data.HashMap.UnsafeShift (unsafeShiftL, unsafeShiftR) import Data.Typeable (Typeable) #if defined(__GLASGOW_HASKELL__) import Data.Data hiding (Typeable) import GHC.Exts ((==#), build, reallyUnsafePtrEquality#) #endif ------------------------------------------------------------------------ -- | Convenience function. Compute a hash value for the given value. hash :: H.Hashable a => a -> Hash hash = fromIntegral . H.hash data Leaf k v = L !k v deriving (Eq) instance (NFData k, NFData v) => NFData (Leaf k v) where rnf (L k v) = rnf k `seq` rnf v -- Invariant: The length of the 1st argument to 'Full' is -- 2^bitsPerSubkey -- | A map from keys to values. A map cannot contain duplicate keys; -- each key can map to at most one value. data HashMap k v = Empty | BitmapIndexed !Bitmap !(A.Array (HashMap k v)) | Leaf !Hash !(Leaf k v) | Full !(A.Array (HashMap k v)) | Collision !Hash !(A.Array (Leaf k v)) deriving (Typeable) instance (NFData k, NFData v) => NFData (HashMap k v) where rnf Empty = () rnf (BitmapIndexed _ ary) = rnf ary rnf (Leaf _ l) = rnf l rnf (Full ary) = rnf ary rnf (Collision _ ary) = rnf ary instance Functor (HashMap k) where fmap = map instance Foldable.Foldable (HashMap k) where foldr f = foldrWithKey (const f) instance (Eq k, Hashable k) => Monoid (HashMap k v) where mempty = empty {-# INLINE mempty #-} mappend = union {-# INLINE mappend #-} #if __GLASGOW_HASKELL__ instance (Data k, Data v, Eq k, Hashable k) => Data (HashMap k v) where gfoldl f z m = z fromList `f` toList m toConstr _ = fromListConstr gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashMapDataType dataCast2 f = gcast2 f fromListConstr :: Constr fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix hashMapDataType :: DataType hashMapDataType = mkDataType "Data.HashMap.Base.HashMap" [fromListConstr] #endif type Hash = Word type Bitmap = Word type Shift = Int instance (Show k, Show v) => Show (HashMap k v) where show m = "fromList " ++ show (toList m) instance Traversable (HashMap k) where traverse f = traverseWithKey (const f) instance (Eq k, Eq v) => Eq (HashMap k v) where (==) = equal equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool equal t1 t2 = go (toList' t1 []) (toList' t2 []) where -- If the two trees are the same, then their lists of 'Leaf's and -- 'Collision's read from left to right should be the same (modulo the -- order of elements in 'Collision'). go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) | k1 == k2 && l1 == l2 = go tl1 tl2 go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) | k1 == k2 && A.length ary1 == A.length ary2 && L.null (A.toList ary1 L.\\ A.toList ary2) = go tl1 tl2 go [] [] = True go _ _ = False toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary toList' (Full ary) a = A.foldr toList' a ary toList' l@(Leaf _ _) a = l : a toList' c@(Collision _ _) a = c : a toList' Empty a = a -- Helper function to detect 'Leaf's and 'Collision's. isLeafOrCollision :: HashMap k v -> Bool isLeafOrCollision (Leaf _ _) = True isLeafOrCollision (Collision _ _) = True isLeafOrCollision _ = False ------------------------------------------------------------------------ -- * Construction -- | /O(1)/ Construct an empty map. empty :: HashMap k v empty = Empty -- | /O(1)/ Construct a map with a single element. singleton :: (Hashable k) => k -> v -> HashMap k v singleton k v = Leaf (hash k) (L k v) ------------------------------------------------------------------------ -- * Basic interface -- | /O(1)/ Return 'True' if this map is empty, 'False' otherwise. null :: HashMap k v -> Bool null Empty = True null _ = False -- | /O(n)/ Return the number of key-value mappings in this map. size :: HashMap k v -> Int size t = go t 0 where go Empty !n = n go (Leaf _ _) n = n + 1 go (BitmapIndexed _ ary) n = A.foldl' (flip go) n ary go (Full ary) n = A.foldl' (flip go) n ary go (Collision _ ary) n = n + A.length ary -- | /O(log n)/ Return 'True' if the specified key is present in the -- map, 'False' otherwise. member :: (Eq k, Hashable k) => k -> HashMap k a -> Bool member k m = case lookup k m of Nothing -> False Just _ -> True #if __GLASGOW_HASKELL__ >= 700 {-# INLINEABLE member #-} #endif -- | /O(log n)/ Return the value to which the specified key is mapped, -- or 'Nothing' if this map contains no mapping for the key. lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v lookup k0 = go h0 k0 0 where h0 = hash k0 go !_ !_ !_ Empty = Nothing go h k _ (Leaf hx (L kx x)) | h == hx && k == kx = Just x -- TODO: Split test in two | otherwise = Nothing go h k s (BitmapIndexed b v) | b .&. m == 0 = Nothing | otherwise = go h k (s+bitsPerSubkey) (A.index v (sparseIndex b m)) where m = mask h s go h k s (Full v) = go h k (s+bitsPerSubkey) (A.index v (index h s)) go h k _ (Collision hx v) | h == hx = lookupInArray k v | otherwise = Nothing #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookup #-} #endif -- | /O(log n)/ Return the value to which the specified key is mapped, -- or the default value if this map contains no mapping for the key. lookupDefault :: (Eq k, Hashable k) => v -- ^ Default value to return. -> k -> HashMap k v -> v lookupDefault def k t = case lookup k t of Just v -> v _ -> def {-# INLINABLE lookupDefault #-} -- | /O(log n)/ Return the value to which the specified key is mapped. -- Calls 'error' if this map contains no mapping for the key. (!) :: (Eq k, Hashable k) => HashMap k v -> k -> v (!) m k = case lookup k m of Just v -> v Nothing -> error "Data.HashMap.Base.(!): key not found" {-# INLINABLE (!) #-} infixl 9 ! -- | Create a 'Collision' value with two 'Leaf' values. collision :: Hash -> Leaf k v -> Leaf k v -> HashMap k v collision h e1 e2 = let v = A.run $ do mary <- A.new 2 e1 A.write mary 1 e2 return mary in Collision h v {-# INLINE collision #-} -- | Create a 'BitmapIndexed' or 'Full' node. bitmapIndexedOrFull :: Bitmap -> A.Array (HashMap k v) -> HashMap k v bitmapIndexedOrFull b ary | b == fullNodeMask = Full ary | otherwise = BitmapIndexed b ary {-# INLINE bitmapIndexedOrFull #-} -- | /O(log n)/ Associate the specified value with the specified -- key in this map. If this map previously contained a mapping for -- the key, the old value is replaced. insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v insert k0 v0 m0 = go h0 k0 v0 0 m0 where h0 = hash k0 go !h !k x !_ Empty = Leaf h (L k x) go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k then if x `ptrEq` y then t else Leaf h (L k x) else collision h l (L k x) | otherwise = runST (two s h k x hy ky y) go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = let ary' = A.insert ary i $! Leaf h (L k x) in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i !st' = go h k x (s+bitsPerSubkey) st in if st' `ptrEq` st then t else BitmapIndexed b (A.update ary i st') where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = let !st = A.index ary i !st' = go h k x (s+bitsPerSubkey) st in if st' `ptrEq` st then t else Full (update16 ary i st') where i = index h s go h k x s t@(Collision hy v) | h == hy = Collision h (updateOrSnocWith const k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #endif -- | In-place update version of insert unsafeInsert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v unsafeInsert k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k then if x `ptrEq` y then return t else return $! Leaf h (L k x) else return $! collision h l (L k x) | otherwise = two s h k x hy ky y go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! Leaf h (L k x) return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where i = index h s go h k x s t@(Collision hy v) | h == hy = return $! Collision h (updateOrSnocWith const k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unsafeInsert #-} #endif -- | Create a map from two key-value pairs which hashes don't collide. two :: Shift -> Hash -> k -> v -> Hash -> k -> v -> ST s (HashMap k v) two = go where go s h1 k1 v1 h2 k2 v2 | bp1 == bp2 = do st <- go (s+bitsPerSubkey) h1 k1 v1 h2 k2 v2 ary <- A.singletonM st return $! BitmapIndexed bp1 ary | otherwise = do mary <- A.new 2 $ Leaf h1 (L k1 v1) A.write mary idx2 $ Leaf h2 (L k2 v2) ary <- A.unsafeFreeze mary return $! BitmapIndexed (bp1 .|. bp2) ary where bp1 = mask h1 s bp2 = mask h2 s idx2 | index h1 s < index h2 s = 1 | otherwise = 0 {-# INLINE two #-} -- | /O(log n)/ Associate the value with the key in this map. If -- this map previously contained a mapping for the key, the old value -- is replaced by the result of applying the given function to the new -- and old value. Example: -- -- > insertWith f k v map -- > where f new old = new + old insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v insertWith f k0 v0 m0 = go h0 k0 v0 0 m0 where h0 = hash k0 go !h !k x !_ Empty = Leaf h (L k x) go h k x s (Leaf hy l@(L ky y)) | hy == h = if ky == k then Leaf h (L k (f x y)) else collision h l (L k x) | otherwise = runST (two s h k x hy ky y) go h k x s (BitmapIndexed b ary) | b .&. m == 0 = let ary' = A.insert ary i $! Leaf h (L k x) in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = update16 ary i $! st' in Full ary' where i = index h s go h k x s t@(Collision hy v) | h == hy = Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWith #-} #endif -- | In-place update version of insertWith unsafeInsertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s (Leaf hy l@(L ky y)) | hy == h = if ky == k then return $! Leaf h (L k (f x y)) else return $! collision h l (L k x) | otherwise = two s h k x hy ky y go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! Leaf h (L k x) return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where i = index h s go h k x s t@(Collision hy v) | h == hy = return $! Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unsafeInsertWith #-} #endif -- | /O(log n)/ Remove the mapping for the specified key from this map -- if present. delete :: (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v delete k0 m0 = go h0 k0 0 m0 where h0 = hash k0 go !_ !_ !_ Empty = Empty go h k _ t@(Leaf hy (L ky _)) | hy == h && ky == k = Empty | otherwise = t go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let !st = A.index ary i !st' = go h k (s+bitsPerSubkey) st in if st' `ptrEq` st then t else case st' of Empty | A.length ary == 1 -> Empty | A.length ary == 2 -> case (i, A.index ary 0, A.index ary 1) of (0, _, l) | isLeafOrCollision l -> l (1, l, _) | isLeafOrCollision l -> l _ -> bIndexed | otherwise -> bIndexed where bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i) l | isLeafOrCollision l && A.length ary == 1 -> l _ -> BitmapIndexed b (A.update ary i st') where m = mask h s i = sparseIndex b m go h k s t@(Full ary) = let !st = A.index ary i !st' = go h k (s+bitsPerSubkey) st in if st' `ptrEq` st then t else case st' of Empty -> let ary' = A.delete ary i bm = fullNodeMask .&. complement (1 `unsafeShiftL` i) in BitmapIndexed bm ary' _ -> Full (A.update ary i st') where i = index h s go h k _ t@(Collision hy v) | h == hy = case indexOf k v of Just i | A.length v == 2 -> if i == 0 then Leaf h (A.index v 1) else Leaf h (A.index v 0) | otherwise -> Collision h (A.delete v i) Nothing -> t | otherwise = t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE delete #-} #endif -- | /O(log n)/ Adjust the value tied to a given key in this map only -- if it is present. Otherwise, leave the map alone. adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v adjust f k0 = go h0 k0 0 where h0 = hash k0 go !_ !_ !_ Empty = Empty go h k _ t@(Leaf hy (L ky y)) | hy == h && ky == k = Leaf h (L k (f y)) | otherwise = t go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let st = A.index ary i st' = go h k (s+bitsPerSubkey) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k s (Full ary) = let i = index h s st = A.index ary i st' = go h k (s+bitsPerSubkey) st ary' = update16 ary i $! st' in Full ary' go h k _ t@(Collision hy v) | h == hy = Collision h (updateWith f k v) | otherwise = t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjust #-} #endif ------------------------------------------------------------------------ -- * Combine -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, the -- mapping from the first will be the mapping in the result. union :: (Eq k, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v union = unionWith const #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE union #-} #endif -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result. unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = go 0 where -- empty vs. anything go !_ t1 Empty = t1 go _ Empty t2 = t2 -- leaf vs. leaf go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) | h1 == h2 = if k1 == k2 then Leaf h1 (L k1 (f v1 v2)) else collision h1 l1 l2 | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrSnocWith f k1 v1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) | h1 == h2 = Collision h1 (updateOrSnocWith (flip f) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrConcatWith f ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2 ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 in bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 in Full ary' -- leaf vs. branch go s (BitmapIndexed b1 ary1) t2 | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 b' = b1 .|. m2 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2 m2 = mask h2 s i = sparseIndex b1 m2 go s t1 (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 b' = b2 .|. m1 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1 m1 = mask h1 s i = sparseIndex b2 m1 go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in Full ary' leafHashCode (Leaf h _) = h leafHashCode (Collision h _) = h leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where m1 = mask h1 s m2 = mask h2 s {-# INLINE unionWith #-} -- | Strict in the result of @f@. unionArrayBy :: (a -> a -> a) -> Bitmap -> Bitmap -> A.Array a -> A.Array a -> A.Array a unionArrayBy f b1 b2 ary1 ary2 = A.run $ do let b' = b1 .|. b2 mary <- A.new_ (popCount b') -- iterate over nonzero bits of b1 .|. b2 -- it would be nice if we could shift m by more than 1 each time let ba = b1 .&. b2 go !i !i1 !i2 !m | m > b' = return () | b' .&. m == 0 = go i i1 i2 (m `unsafeShiftL` 1) | ba .&. m /= 0 = do A.write mary i $! f (A.index ary1 i1) (A.index ary2 i2) go (i+1) (i1+1) (i2+1) (m `unsafeShiftL` 1) | b1 .&. m /= 0 = do A.write mary i =<< A.indexM ary1 i1 go (i+1) (i1+1) (i2 ) (m `unsafeShiftL` 1) | otherwise = do A.write mary i =<< A.indexM ary2 i2 go (i+1) (i1 ) (i2+1) (m `unsafeShiftL` 1) go 0 0 0 (b' .&. negate b') -- XXX: b' must be non-zero return mary -- TODO: For the case where b1 .&. b2 == b1, i.e. when one is a -- subset of the other, we could use a slightly simpler algorithm, -- where we copy one array, and then update. {-# INLINE unionArrayBy #-} -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets. unions :: (Eq k, Hashable k) => [HashMap k v] -> HashMap k v unions = L.foldl' union empty {-# INLINE unions #-} ------------------------------------------------------------------------ -- * Transformations -- | /O(n)/ Transform this map by applying a function to every value. mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 mapWithKey f = go where go Empty = Empty go (Leaf h (L k v)) = Leaf h $ L k (f k v) go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary go (Full ary) = Full $ A.map' go ary go (Collision h ary) = Collision h $ A.map' (\ (L k v) -> L k (f k v)) ary {-# INLINE mapWithKey #-} map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = mapWithKey (const f) {-# INLINE map #-} -- TODO: We should be able to use mutation to create the new -- 'HashMap'. -- | /O(n)/ Transform this map by accumulating an Applicative result -- from every value. traverseWithKey :: Applicative f => (k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2) traverseWithKey f = go where go Empty = pure Empty go (Leaf h (L k v)) = Leaf h . L k <$> f k v go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse go ary go (Full ary) = Full <$> A.traverse go ary go (Collision h ary) = Collision h <$> A.traverse (\ (L k v) -> L k <$> f k v) ary {-# INLINE traverseWithKey #-} ------------------------------------------------------------------------ -- * Difference and intersection -- | /O(n*log m)/ Difference of two maps. Return elements of the first map -- not existing in the second. difference :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v difference a b = foldlWithKey' go empty a where go m k v = case lookup k b of Nothing -> insert k v m _ -> m #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE difference #-} #endif -- | /O(n*log m)/ Intersection of two maps. Return elements of the first -- map for keys existing in the second. intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v intersection a b = foldlWithKey' go empty a where go m k v = case lookup k b of Just _ -> insert k v m _ -> m #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersection #-} #endif -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f a b = foldlWithKey' go empty a where go m k v = case lookup k b of Just w -> insert k (f v w) m _ -> m #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersectionWith #-} #endif ------------------------------------------------------------------------ -- * Folds -- | /O(n)/ Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). Each application of the operator -- is evaluated before before using the result in the next -- application. This function is strict in the starting value. foldl' :: (a -> v -> a) -> a -> HashMap k v -> a foldl' f = foldlWithKey' (\ z _ v -> f z v) {-# INLINE foldl' #-} -- | /O(n)/ Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). Each application of the operator -- is evaluated before before using the result in the next -- application. This function is strict in the starting value. foldlWithKey' :: (a -> k -> v -> a) -> a -> HashMap k v -> a foldlWithKey' f = go where go !z Empty = z go z (Leaf _ (L k v)) = f z k v go z (BitmapIndexed _ ary) = A.foldl' go z ary go z (Full ary) = A.foldl' go z ary go z (Collision _ ary) = A.foldl' (\ z' (L k v) -> f z' k v) z ary {-# INLINE foldlWithKey' #-} -- | /O(n)/ Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). foldr :: (v -> a -> a) -> a -> HashMap k v -> a foldr f = foldrWithKey (const f) {-# INLINE foldr #-} -- | /O(n)/ Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a foldrWithKey f = go where go z Empty = z go z (Leaf _ (L k v)) = f k v z go z (BitmapIndexed _ ary) = A.foldr (flip go) z ary go z (Full ary) = A.foldr (flip go) z ary go z (Collision _ ary) = A.foldr (\ (L k v) z' -> f k v z') z ary {-# INLINE foldrWithKey #-} ------------------------------------------------------------------------ -- * Filter -- | Create a new array of the @n@ first elements of @mary@. trim :: A.MArray s a -> Int -> ST s (A.Array a) trim mary n = do mary2 <- A.new_ n A.copyM mary 0 mary2 0 n A.unsafeFreeze mary2 {-# INLINE trim #-} -- | /O(n)/ Filter this map by retaining only elements satisfying a -- predicate. filterWithKey :: (k -> v -> Bool) -> HashMap k v -> HashMap k v filterWithKey pred = go where go Empty = Empty go t@(Leaf _ (L k v)) | pred k v = t | otherwise = Empty go (BitmapIndexed b ary) = filterA ary b go (Full ary) = filterA ary fullNodeMask go (Collision h ary) = filterC ary h filterA ary0 b0 = let !n = A.length ary0 in runST $ do mary <- A.new_ n step ary0 mary b0 0 0 1 n where step !ary !mary !b i !j !bi n | i >= n = case j of 0 -> return Empty 1 -> do ch <- A.read mary 0 case ch of t | isLeafOrCollision t -> return t _ -> BitmapIndexed b <$> trim mary 1 _ -> do ary2 <- trim mary j return $! if j == maxChildren then Full ary2 else BitmapIndexed b ary2 | bi .&. b == 0 = step ary mary b i j (bi `unsafeShiftL` 1) n | otherwise = case go (A.index ary i) of Empty -> step ary mary (b .&. complement bi) (i+1) j (bi `unsafeShiftL` 1) n t -> do A.write mary j t step ary mary b (i+1) (j+1) (bi `unsafeShiftL` 1) n filterC ary0 h = let !n = A.length ary0 in runST $ do mary <- A.new_ n step ary0 mary 0 0 n where step !ary !mary i !j n | i >= n = case j of 0 -> return Empty 1 -> do l <- A.read mary 0 return $! Leaf h l _ | i == j -> do ary2 <- A.unsafeFreeze mary return $! Collision h ary2 | otherwise -> do ary2 <- trim mary j return $! Collision h ary2 | pred k v = A.write mary j el >> step ary mary (i+1) (j+1) n | otherwise = step ary mary (i+1) j n where el@(L k v) = A.index ary i {-# INLINE filterWithKey #-} -- | /O(n)/ Filter this map by retaining only elements which values -- satisfy a predicate. filter :: (v -> Bool) -> HashMap k v -> HashMap k v filter p = filterWithKey (\_ v -> p v) {-# INLINE filter #-} ------------------------------------------------------------------------ -- * Conversions -- TODO: Improve fusion rules by modelled them after the Prelude ones -- on lists. -- | /O(n)/ Return a list of this map's keys. The list is produced -- lazily. keys :: HashMap k v -> [k] keys = L.map fst . toList {-# INLINE keys #-} -- | /O(n)/ Return a list of this map's values. The list is produced -- lazily. elems :: HashMap k v -> [v] elems = L.map snd . toList {-# INLINE elems #-} ------------------------------------------------------------------------ -- ** Lists -- | /O(n)/ Return a list of this map's elements. The list is -- produced lazily. toList :: HashMap k v -> [(k, v)] #if defined(__GLASGOW_HASKELL__) toList t = build (\ c z -> foldrWithKey (curry c) z t) #else toList = foldrWithKey (\ k v xs -> (k, v) : xs) [] #endif {-# INLINE toList #-} -- | /O(n)/ Construct a map with the supplied mappings. If the list -- contains duplicate mappings, the later mappings take precedence. fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v fromList = L.foldl' (\ m (k, v) -> unsafeInsert k v m) empty #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif -- | /O(n*log n)/ Construct a map from a list of elements. Uses -- the provided function to merge duplicate entries. fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty #if __GLASGOW_HASKELL__ >= 700 {-# INLINE fromListWith #-} #endif ------------------------------------------------------------------------ -- Array operations -- | /O(n)/ Lookup the value associated with the given key in this -- array. Returns 'Nothing' if the key wasn't found. lookupInArray :: Eq k => k -> A.Array (Leaf k v) -> Maybe v lookupInArray k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n | i >= n = Nothing | otherwise = case A.index ary i of (L kx v) | k == kx -> Just v | otherwise -> go k ary (i+1) n #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE lookupInArray #-} #endif -- | /O(n)/ Lookup the value associated with the given key in this -- array. Returns 'Nothing' if the key wasn't found. indexOf :: Eq k => k -> A.Array (Leaf k v) -> Maybe Int indexOf k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n | i >= n = Nothing | otherwise = case A.index ary i of (L kx _) | k == kx -> Just i | otherwise -> go k ary (i+1) n #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE indexOf #-} #endif updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n | i >= n = ary | otherwise = case A.index ary i of (L kx y) | k == kx -> A.update ary i (L k (f y)) | otherwise -> go k ary (i+1) n #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateWith #-} #endif updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrSnocWith f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) where go !k v !ary !i !n | i >= n = A.run $ do -- Not found, append to the end. mary <- A.new_ (n + 1) A.copy ary 0 mary 0 n A.write mary n (L k v) return mary | otherwise = case A.index ary i of (L kx y) | k == kx -> A.update ary i (L k (f v y)) | otherwise -> go k v ary (i+1) n #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateOrSnocWith #-} #endif updateOrConcatWith :: Eq k => (v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrConcatWith f ary1 ary2 = A.run $ do -- first: look up the position of each element of ary2 in ary1 let indices = A.map (\(L k _) -> indexOf k ary1) ary2 -- that tells us how large the overlap is: -- count number of Nothing constructors let nOnly2 = A.foldl' (\n -> maybe (n+1) (const n)) 0 indices let n1 = A.length ary1 let n2 = A.length ary2 -- copy over all elements from ary1 mary <- A.new_ (n1 + nOnly2) A.copy ary1 0 mary 0 n1 -- append or update all elements from ary2 let go !iEnd !i2 | i2 >= n2 = return () | otherwise = case A.index indices i2 of Just i1 -> do -- key occurs in both arrays, store combination in position i1 L k v1 <- A.indexM ary1 i1 L _ v2 <- A.indexM ary2 i2 A.write mary i1 (L k (f v1 v2)) go iEnd (i2+1) Nothing -> do -- key is only in ary2, append to end A.write mary iEnd =<< A.indexM ary2 i2 go (iEnd+1) (i2+1) go n1 0 return mary #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateOrConcatWith #-} #endif ------------------------------------------------------------------------ -- Manually unrolled loops -- | /O(n)/ Update the element at the given position in this array. update16 :: A.Array e -> Int -> e -> A.Array e update16 ary idx b = runST (update16M ary idx b) {-# INLINE update16 #-} -- | /O(n)/ Update the element at the given position in this array. update16M :: A.Array e -> Int -> e -> ST s (A.Array e) update16M ary idx b = do mary <- clone16 ary A.write mary idx b A.unsafeFreeze mary {-# INLINE update16M #-} -- | /O(n)/ Update the element at the given position in this array, by applying a function to it. update16With' :: A.Array e -> Int -> (e -> e) -> A.Array e update16With' ary idx f = update16 ary idx $! f (A.index ary idx) {-# INLINE update16With' #-} -- | Unsafely clone an array of 16 elements. The length of the input -- array is not checked. clone16 :: A.Array e -> ST s (A.MArray s e) clone16 ary = #if __GLASGOW_HASKELL__ >= 702 A.thaw ary 0 16 #else do mary <- A.new_ 16 A.indexM ary 0 >>= A.write mary 0 A.indexM ary 1 >>= A.write mary 1 A.indexM ary 2 >>= A.write mary 2 A.indexM ary 3 >>= A.write mary 3 A.indexM ary 4 >>= A.write mary 4 A.indexM ary 5 >>= A.write mary 5 A.indexM ary 6 >>= A.write mary 6 A.indexM ary 7 >>= A.write mary 7 A.indexM ary 8 >>= A.write mary 8 A.indexM ary 9 >>= A.write mary 9 A.indexM ary 10 >>= A.write mary 10 A.indexM ary 11 >>= A.write mary 11 A.indexM ary 12 >>= A.write mary 12 A.indexM ary 13 >>= A.write mary 13 A.indexM ary 14 >>= A.write mary 14 A.indexM ary 15 >>= A.write mary 15 return mary #endif ------------------------------------------------------------------------ -- Bit twiddling bitsPerSubkey :: Int bitsPerSubkey = 4 maxChildren :: Int maxChildren = fromIntegral $ 1 `unsafeShiftL` bitsPerSubkey subkeyMask :: Bitmap subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1 sparseIndex :: Bitmap -> Bitmap -> Int sparseIndex b m = popCount (b .&. (m - 1)) mask :: Word -> Shift -> Bitmap mask w s = 1 `unsafeShiftL` index w s {-# INLINE mask #-} -- | Mask out the 'bitsPerSubkey' bits used for indexing at this level -- of the tree. index :: Hash -> Shift -> Int index w s = fromIntegral $ (unsafeShiftR w s) .&. subkeyMask {-# INLINE index #-} -- | A bitmask with the 'bitsPerSubkey' least significant bits set. fullNodeMask :: Bitmap fullNodeMask = complement (complement 0 `unsafeShiftL` maxChildren) {-# INLINE fullNodeMask #-} -- | Check if two the two arguments are the same value. N.B. This -- function might give false negatives (due to GC moving objects.) ptrEq :: a -> a -> Bool #if defined(__GLASGOW_HASKELL__) ptrEq x y = reallyUnsafePtrEquality# x y ==# 1# #else ptrEq _ _ = False #endif {-# INLINE ptrEq #-} unordered-containers-0.2.3.0/Data/HashMap/Lazy.hs0000644000000000000000000000354712062470243017650 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Lazy -- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional -- Portability : portable -- -- A map from /hashable/ keys to values. A map cannot contain -- duplicate keys; each key can map to at most one value. A 'HashMap' -- makes no guarantees as to the order of its elements. -- -- This map is strict in the keys and lazy in the values; keys are -- evaluated to /weak head normal form/ before they are added to the -- map. -- -- The implementation is based on /hash array mapped tries/. A -- 'HashMap' is often faster than other tree-based set types, -- especially when key comparison is expensive, as in the case of -- strings. -- -- Many operations have a average-case complexity of /O(log n)/. The -- implementation uses a large base (i.e. 16) so in practice these -- operations are constant time. module Data.HashMap.Lazy ( HashMap -- * Construction , empty , singleton -- * Basic interface , HM.null , size , member , HM.lookup , lookupDefault , (!) , insert , insertWith , delete , adjust -- * Combine -- ** Union , union , unionWith , unions -- * Transformations , HM.map , traverseWithKey -- * Difference and intersection , difference , intersection , intersectionWith -- * Folds , foldl' , foldlWithKey' , HM.foldr , foldrWithKey -- * Filter , HM.filter , filterWithKey -- * Conversions , keys , elems -- ** Lists , toList , fromList , fromListWith ) where import Data.HashMap.Base as HM unordered-containers-0.2.3.0/Data/HashMap/PopCount.hs0000644000000000000000000000064312062470243020472 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Data.HashMap.PopCount ( popCount ) where #if __GLASGOW_HASKELL__ >= 704 import Data.Bits (popCount) #else import Data.Word (Word) import Foreign.C (CUInt) #endif #if __GLASGOW_HASKELL__ < 704 foreign import ccall unsafe "popc.h popcount" c_popcount :: CUInt -> CUInt popCount :: Word -> Int popCount w = fromIntegral (c_popcount (fromIntegral w)) #endifunordered-containers-0.2.3.0/Data/HashMap/Strict.hs0000644000000000000000000003416312062470243020177 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Strict -- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional -- Portability : portable -- -- A map from /hashable/ keys to values. A map cannot contain -- duplicate keys; each key can map to at most one value. A 'HashMap' -- makes no guarantees as to the order of its elements. -- -- This map is strict in both the keys and the values; keys and values -- are evaluated to /weak head normal form/ before they are added to -- the map. Exception: the provided instances are the same as for the -- lazy version of this module. -- -- The implementation is based on /hash array mapped tries/. A -- 'HashMap' is often faster than other tree-based set types, -- especially when key comparison is expensive, as in the case of -- strings. -- -- Many operations have a average-case complexity of /O(log n)/. The -- implementation uses a large base (i.e. 16) so in practice these -- operations are constant time. module Data.HashMap.Strict ( HashMap -- * Construction , empty , singleton -- * Basic interface , HM.null , size , HM.member , HM.lookup , lookupDefault , (!) , insert , insertWith , delete , adjust -- * Combine -- ** Union , union , unionWith , unions -- * Transformations , map , traverseWithKey -- * Difference and intersection , difference , intersection , intersectionWith -- * Folds , foldl' , foldlWithKey' , HM.foldr , foldrWithKey -- * Filter , HM.filter , filterWithKey -- * Conversions , keys , elems -- ** Lists , toList , fromList , fromListWith ) where import Data.Bits ((.&.), (.|.)) import qualified Data.List as L import Data.Hashable (Hashable) import Prelude hiding (map) import qualified Data.HashMap.Array as A import qualified Data.HashMap.Base as HM import Data.HashMap.Base hiding ( adjust, fromList, fromListWith, insert, insertWith, intersectionWith, lookupDefault, map, singleton, unionWith) import Data.HashMap.Unsafe (runST) ------------------------------------------------------------------------ -- * Construction -- | /O(1)/ Construct a map with a single element. singleton :: (Hashable k) => k -> v -> HashMap k v singleton k !v = HM.singleton k v ------------------------------------------------------------------------ -- * Basic interface -- | /O(log n)/ Return the value to which the specified key is mapped, -- or the default value if this map contains no mapping for the key. lookupDefault :: (Eq k, Hashable k) => v -- ^ Default value to return. -> k -> HashMap k v -> v lookupDefault !def k t = HM.lookupDefault def k t {-# INLINABLE lookupDefault #-} -- | /O(log n)/ Associate the specified value with the specified -- key in this map. If this map previously contained a mapping for -- the key, the old value is replaced. insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v insert k !v = HM.insert k v #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #endif -- | /O(log n)/ Associate the value with the key in this map. If -- this map previously contained a mapping for the key, the old value -- is replaced by the result of applying the given function to the new -- and old value. Example: -- -- > insertWith f k v map -- > where f new old = new + old insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v insertWith f k0 !v0 m0 = go h0 k0 v0 0 m0 where h0 = hash k0 go !h !k x !_ Empty = Leaf h (L k x) go h k x s (Leaf hy l@(L ky y)) | hy == h = if ky == k then let !v' = f x y in Leaf h (L k v') else collision h l (L k x) | otherwise = runST (two s h k x hy ky y) go h k x s (BitmapIndexed b ary) | b .&. m == 0 = let ary' = A.insert ary i $! Leaf h (L k x) in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = update16 ary i $! st' in Full ary' where i = index h s go h k x s t@(Collision hy v) | h == hy = Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWith #-} #endif -- | In-place update version of insertWith unsafeInsertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s (Leaf hy l@(L ky y)) | hy == h = if ky == k then let !v' = f x y in return $! Leaf h (L k v') else return $! collision h l (L k x) | otherwise = two s h k x hy ky y go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! Leaf h (L k x) return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where i = index h s go h k x s t@(Collision hy v) | h == hy = return $! Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE unsafeInsertWith #-} #endif -- | /O(log n)/ Adjust the value tied to a given key in this map only -- if it is present. Otherwise, leave the map alone. adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v adjust f k0 = go h0 k0 0 where h0 = hash k0 go !_ !_ !_ Empty = Empty go h k _ t@(Leaf hy (L ky y)) | hy == h && ky == k = let !v' = f y in Leaf h (L k v') | otherwise = t go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let st = A.index ary i st' = go h k (s+bitsPerSubkey) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k s (Full ary) = let i = index h s st = A.index ary i st' = go h k (s+bitsPerSubkey) st ary' = update16 ary i $! st' in Full ary' go h k _ t@(Collision hy v) | h == hy = Collision h (updateWith f k v) | otherwise = t #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjust #-} #endif ------------------------------------------------------------------------ -- * Combine -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = go 0 where -- empty vs. anything go !_ t1 Empty = t1 go _ Empty t2 = t2 -- leaf vs. leaf go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) | h1 == h2 = if k1 == k2 then Leaf h1 . L k1 $! f v1 v2 else collision h1 l1 l2 | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrSnocWith f k1 v1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) | h1 == h2 = Collision h1 (updateOrSnocWith (flip f) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrConcatWith f ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2 ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 in bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 in Full ary' -- leaf vs. branch go s (BitmapIndexed b1 ary1) t2 | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 b' = b1 .|. m2 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2 m2 = mask h2 s i = sparseIndex b1 m2 go s t1 (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 b' = b2 .|. m1 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1 m1 = mask h1 s i = sparseIndex b2 m1 go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in Full ary' leafHashCode (Leaf h _) = h leafHashCode (Collision h _) = h leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where m1 = mask h1 s m2 = mask h2 s {-# INLINE unionWith #-} ------------------------------------------------------------------------ -- * Transformations -- | /O(n)/ Transform this map by applying a function to every value. mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 mapWithKey f = go where go Empty = Empty go (Leaf h (L k v)) = let !v' = f k v in Leaf h $ L k v' go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary go (Full ary) = Full $ A.map' go ary go (Collision h ary) = Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary {-# INLINE mapWithKey #-} map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = mapWithKey (const f) {-# INLINE map #-} -- TODO: Should we add a strict traverseWithKey? ------------------------------------------------------------------------ -- * Difference and intersection -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f a b = foldlWithKey' go empty a where go m k v = case HM.lookup k b of Just w -> insert k (f v w) m _ -> m #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE intersectionWith #-} #endif ------------------------------------------------------------------------ -- ** Lists -- | /O(n*log n)/ Construct a map with the supplied mappings. If the -- list contains duplicate mappings, the later mappings take -- precedence. fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v fromList = L.foldl' (\ m (k, v) -> HM.unsafeInsert k v m) empty #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif -- | /O(n*log n)/ Construct a map from a list of elements. Uses -- the provided function to merge duplicate entries. fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty {-# INLINE fromListWith #-} ------------------------------------------------------------------------ -- Array operations updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n | i >= n = ary | otherwise = case A.index ary i of (L kx y) | k == kx -> let !v' = f y in A.update ary i (L k v') | otherwise -> go k ary (i+1) n #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateWith #-} #endif updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrSnocWith f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) where go !k v !ary !i !n | i >= n = A.run $ do -- Not found, append to the end. mary <- A.new_ (n + 1) A.copy ary 0 mary 0 n A.write mary n (L k v) return mary | otherwise = case A.index ary i of (L kx y) | k == kx -> let !v' = f v y in A.update ary i (L k v') | otherwise -> go k v ary (i+1) n #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateOrSnocWith #-} #endif unordered-containers-0.2.3.0/Data/HashMap/Unsafe.hs0000644000000000000000000000162612062470243020146 0ustar0000000000000000{-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-} -- | This module exports a workaround for this bug: -- -- http://hackage.haskell.org/trac/ghc/ticket/5916 -- -- Please read the comments in ghc/libraries/base/GHC/ST.lhs to -- understand what's going on here. -- -- Code that uses this module should be compiled with -fno-full-laziness module Data.HashMap.Unsafe ( runST ) where import GHC.Base (realWorld#) import GHC.ST hiding (runST, runSTRep) -- | Return the value computed by a state transformer computation. -- The @forall@ ensures that the internal state used by the 'ST' -- computation is inaccessible to the rest of the program. runST :: (forall s. ST s a) -> a runST st = runSTRep (case st of { ST st_rep -> st_rep }) {-# INLINE runST #-} runSTRep :: (forall s. STRep s a) -> a runSTRep st_rep = case st_rep realWorld# of (# _, r #) -> r {-# INLINE [0] runSTRep #-} unordered-containers-0.2.3.0/Data/HashMap/UnsafeShift.hs0000644000000000000000000000066512062470243021146 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module Data.HashMap.UnsafeShift ( unsafeShiftL , unsafeShiftR ) where import GHC.Exts (Word(W#), Int(I#), uncheckedShiftL#, uncheckedShiftRL#) unsafeShiftL :: Word -> Int -> Word unsafeShiftL (W# x#) (I# i#) = W# (x# `uncheckedShiftL#` i#) {-# INLINE unsafeShiftL #-} unsafeShiftR :: Word -> Int -> Word unsafeShiftR (W# x#) (I# i#) = W# (x# `uncheckedShiftRL#` i#) {-# INLINE unsafeShiftR #-} unordered-containers-0.2.3.0/tests/0000755000000000000000000000000012062470243015334 5ustar0000000000000000unordered-containers-0.2.3.0/tests/HashMapProperties.hs0000644000000000000000000002204212062470243021266 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Tests for the 'Data.HashMap.Lazy' module. We test functions by -- comparing them to a simpler model, an association list. module Main (main) where import qualified Data.Foldable as Foldable import Data.Function (on) import Data.Hashable (Hashable(hashWithSalt)) import qualified Data.List as L #if defined(STRICT) import qualified Data.HashMap.Strict as HM #else import qualified Data.HashMap.Lazy as HM #endif import qualified Data.Map as M import Test.QuickCheck (Arbitrary, Property, (==>)) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -- Key type that generates more hash collisions. newtype Key = K { unK :: Int } deriving (Arbitrary, Eq, Ord, Show) instance Hashable Key where hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 ------------------------------------------------------------------------ -- * Properties ------------------------------------------------------------------------ -- ** Instances pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==) pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=) pFunctor :: [(Key, Int)] -> Bool pFunctor = fmap (+ 1) `eq_` fmap (+ 1) pFoldable :: [(Int, Int)] -> Bool pFoldable = (L.sort . Foldable.foldr (:) []) `eq` (L.sort . Foldable.foldr (:) []) ------------------------------------------------------------------------ -- ** Basic interface pSize :: [(Key, Int)] -> Bool pSize = M.size `eq` HM.size pMember :: Key -> [(Key, Int)] -> Bool pMember k = M.member k `eq` HM.member k pLookup :: Key -> [(Key, Int)] -> Bool pLookup k = M.lookup k `eq` HM.lookup k pInsert :: Key -> Int -> [(Key, Int)] -> Bool pInsert k v = M.insert k v `eq_` HM.insert k v pDelete :: Key -> [(Key, Int)] -> Bool pDelete k = M.delete k `eq_` HM.delete k newtype AlwaysCollide = AC Int deriving (Arbitrary, Eq, Ord, Show) instance Hashable AlwaysCollide where hashWithSalt _ _ = 1 -- White-box test that tests the case of deleting one of two keys from -- a map, where the keys' hash values collide. pDeleteCollision :: AlwaysCollide -> AlwaysCollide -> AlwaysCollide -> Int -> Property pDeleteCollision k1 k2 k3 idx = (k1 /= k2) && (k2 /= k3) && (k1 /= k3) ==> HM.member toKeep $ HM.delete toDelete $ HM.fromList [(k1, 1 :: Int), (k2, 2), (k3, 3)] where which = idx `mod` 3 toDelete | which == 0 = k1 | which == 1 = k2 | which == 2 = k3 | otherwise = error "Impossible" toKeep | which == 0 = k2 | which == 1 = k3 | which == 2 = k1 | otherwise = error "Impossible" pInsertWith :: Key -> [(Key, Int)] -> Bool pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1 pAdjust :: Key -> [(Key, Int)] -> Bool pAdjust k = M.adjust succ k `eq_` HM.adjust succ k ------------------------------------------------------------------------ -- ** Combine pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_` HM.unionWith (-) (HM.fromList xs) $ ys pUnions :: [[(Key, Int)]] -> Bool pUnions xss = M.toAscList (M.unions (map M.fromList xss)) == toAscList (HM.unions (map HM.fromList xss)) ------------------------------------------------------------------------ -- ** Transformations pMap :: [(Key, Int)] -> Bool pMap = M.map (+ 1) `eq_` HM.map (+ 1) ------------------------------------------------------------------------ -- ** Difference and intersection pDifference :: [(Key, Int)] -> [(Key, Int)] -> Bool pDifference xs ys = M.difference (M.fromList xs) `eq_` HM.difference (HM.fromList xs) $ ys pIntersection :: [(Key, Int)] -> [(Key, Int)] -> Bool pIntersection xs ys = M.intersection (M.fromList xs) `eq_` HM.intersection (HM.fromList xs) $ ys pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_` HM.intersectionWith (-) (HM.fromList xs) $ ys ------------------------------------------------------------------------ -- ** Folds pFoldr :: [(Int, Int)] -> Bool pFoldr = (L.sort . M.fold (:) []) `eq` (L.sort . HM.foldr (:) []) pFoldrWithKey :: [(Int, Int)] -> Bool pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq` (sortByKey . HM.foldrWithKey f []) where f k v z = (k, v) : z pFoldl' :: Int -> [(Int, Int)] -> Bool pFoldl' z0 = foldlWithKey'Map (\ z _ v -> v + z) z0 `eq` HM.foldl' (+) z0 foldlWithKey'Map :: (b -> k -> a -> b) -> b -> M.Map k a -> b #if MIN_VERSION_containers(4,2,0) foldlWithKey'Map = M.foldlWithKey' #else -- Equivalent except for bottoms, which we don't test. foldlWithKey'Map = M.foldlWithKey #endif ------------------------------------------------------------------------ -- ** Filter pFilter :: [(Key, Int)] -> Bool pFilter = M.filter odd `eq_` HM.filter odd pFilterWithKey :: [(Key, Int)] -> Bool pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p where p k v = odd (unK k + v) ------------------------------------------------------------------------ -- ** Conversions -- 'eq_' already calls fromList. pFromList :: [(Key, Int)] -> Bool pFromList = id `eq_` id pFromListWith :: [(Key, Int)] -> Bool pFromListWith kvs = (M.toAscList $ M.fromListWith (+) kvs) == (toAscList $ HM.fromListWith (+) kvs) pToList :: [(Key, Int)] -> Bool pToList = M.toAscList `eq` toAscList pElems :: [(Key, Int)] -> Bool pElems = (L.sort . M.elems) `eq` (L.sort . HM.elems) pKeys :: [(Key, Int)] -> Bool pKeys = (L.sort . M.keys) `eq` (L.sort . HM.keys) ------------------------------------------------------------------------ -- * Test list tests :: [Test] tests = [ -- Instances testGroup "instances" [ testProperty "==" pEq , testProperty "/=" pNeq , testProperty "Functor" pFunctor , testProperty "Foldable" pFoldable ] -- Basic interface , testGroup "basic interface" [ testProperty "size" pSize , testProperty "member" pMember , testProperty "lookup" pLookup , testProperty "insert" pInsert , testProperty "delete" pDelete , testProperty "deleteCollision" pDeleteCollision , testProperty "insertWith" pInsertWith , testProperty "adjust" pAdjust ] -- Combine , testProperty "union" pUnion , testProperty "unionWith" pUnionWith , testProperty "unions" pUnions -- Transformations , testProperty "map" pMap -- Folds , testGroup "folds" [ testProperty "foldr" pFoldr , testProperty "foldrWithKey" pFoldrWithKey , testProperty "foldl'" pFoldl' ] , testGroup "difference and intersection" [ testProperty "difference" pDifference , testProperty "intersection" pIntersection , testProperty "intersectionWith" pIntersectionWith ] -- Filter , testGroup "filter" [ testProperty "filter" pFilter , testProperty "filterWithKey" pFilterWithKey ] -- Conversions , testGroup "conversions" [ testProperty "elems" pElems , testProperty "keys" pKeys , testProperty "fromList" pFromList , testProperty "fromListWith" pFromListWith , testProperty "toList" pToList ] ] ------------------------------------------------------------------------ -- * Model type Model k v = M.Map k v -- | Check that a function operating on a 'HashMap' is equivalent to -- one operating on a 'Model'. eq :: (Eq a, Eq k, Hashable k, Ord k) => (Model k v -> a) -- ^ Function that modifies a 'Model' -> (HM.HashMap k v -> a) -- ^ Function that modified a 'HashMap' in the same -- way -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model' -> Bool -- ^ True if the functions are equivalent eq f g xs = g (HM.fromList xs) == f (M.fromList xs) eq_ :: (Eq k, Eq v, Hashable k, Ord k) => (Model k v -> Model k v) -- ^ Function that modifies a 'Model' -> (HM.HashMap k v -> HM.HashMap k v) -- ^ Function that modified a -- 'HashMap' in the same way -> [(k, v)] -- ^ Initial content of the 'HashMap' -- and 'Model' -> Bool -- ^ True if the functions are -- equivalent eq_ f g = (M.toAscList . f) `eq` (toAscList . g) ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests ------------------------------------------------------------------------ -- * Helpers sortByKey :: Ord k => [(k, v)] -> [(k, v)] sortByKey = L.sortBy (compare `on` fst) toAscList :: Ord k => HM.HashMap k v -> [(k, v)] toAscList = L.sortBy (compare `on` fst) . HM.toList unordered-containers-0.2.3.0/tests/HashSetProperties.hs0000644000000000000000000001223512062470243021307 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Tests for the 'Data.HashSet' module. We test functions by -- comparing them to a simpler model, a list. module Main (main) where import qualified Data.Foldable as Foldable import Data.Hashable (Hashable(hashWithSalt)) import qualified Data.List as L import qualified Data.HashSet as S import qualified Data.Set as Set import Test.QuickCheck (Arbitrary) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -- Key type that generates more hash collisions. newtype Key = K { unK :: Int } deriving (Arbitrary, Enum, Eq, Integral, Num, Ord, Show, Real) instance Hashable Key where hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 ------------------------------------------------------------------------ -- * Properties ------------------------------------------------------------------------ -- ** Instances pEq :: [Key] -> [Key] -> Bool pEq xs = (Set.fromList xs ==) `eq` (S.fromList xs ==) pNeq :: [Key] -> [Key] -> Bool pNeq xs = (Set.fromList xs /=) `eq` (S.fromList xs /=) pFoldable :: [Int] -> Bool pFoldable = (L.sort . Foldable.foldr (:) []) `eq` (L.sort . Foldable.foldr (:) []) ------------------------------------------------------------------------ -- ** Basic interface pSize :: [Key] -> Bool pSize = Set.size `eq` S.size pMember :: Key -> [Key] -> Bool pMember k = Set.member k `eq` S.member k pInsert :: Key -> [Key] -> Bool pInsert a = Set.insert a `eq_` S.insert a pDelete :: Key -> [Key] -> Bool pDelete a = Set.delete a `eq_` S.delete a ------------------------------------------------------------------------ -- ** Combine pUnion :: [Key] -> [Key] -> Bool pUnion xs ys = Set.union (Set.fromList xs) `eq_` S.union (S.fromList xs) $ ys ------------------------------------------------------------------------ -- ** Transformations pMap :: [Key] -> Bool pMap = Set.map (+ 1) `eq_` S.map (+ 1) ------------------------------------------------------------------------ -- ** Folds pFoldr :: [Int] -> Bool pFoldr = (L.sort . foldrSet (:) []) `eq` (L.sort . S.foldr (:) []) foldrSet :: (a -> b -> b) -> b -> Set.Set a -> b #if MIN_VERSION_containers(0,4,2) foldrSet = Set.foldr #else foldrSet = Foldable.foldr #endif pFoldl' :: Int -> [Int] -> Bool pFoldl' z0 = foldl'Set (+) z0 `eq` S.foldl' (+) z0 foldl'Set :: (a -> b -> a) -> a -> Set.Set b -> a #if MIN_VERSION_containers(0,4,2) foldl'Set = Set.foldl' #else foldl'Set = Foldable.foldl' #endif ------------------------------------------------------------------------ -- ** Filter pFilter :: [Key] -> Bool pFilter = Set.filter odd `eq_` S.filter odd ------------------------------------------------------------------------ -- ** Conversions pToList :: [Key] -> Bool pToList = Set.toAscList `eq` toAscList ------------------------------------------------------------------------ -- * Test list tests :: [Test] tests = [ -- Instances testGroup "instances" [ testProperty "==" pEq , testProperty "/=" pNeq , testProperty "Foldable" pFoldable ] -- Basic interface , testGroup "basic interface" [ testProperty "size" pSize , testProperty "member" pMember , testProperty "insert" pInsert , testProperty "delete" pDelete ] -- Combine , testProperty "union" pUnion -- Transformations , testProperty "map" pMap -- Folds , testGroup "folds" [ testProperty "foldr" pFoldr , testProperty "foldl'" pFoldl' ] -- Filter , testGroup "filter" [ testProperty "filter" pFilter ] -- Conversions , testGroup "conversions" [ testProperty "toList" pToList ] ] ------------------------------------------------------------------------ -- * Model -- Invariant: the list is sorted in ascending order, by key. type Model a = Set.Set a -- | Check that a function operating on a 'HashMap' is equivalent to -- one operating on a 'Model'. eq :: (Eq a, Hashable a, Ord a, Eq b) => (Model a -> b) -- ^ Function that modifies a 'Model' in the same -- way -> (S.HashSet a -> b) -- ^ Function that modified a 'HashSet' -> [a] -- ^ Initial content of the 'HashSet' and 'Model' -> Bool -- ^ True if the functions are equivalent eq f g xs = g (S.fromList xs) == f (Set.fromList xs) eq_ :: (Eq a, Hashable a, Ord a) => (Model a -> Model a) -- ^ Function that modifies a 'Model' -> (S.HashSet a -> S.HashSet a) -- ^ Function that modified a -- 'HashSet' in the same way -> [a] -- ^ Initial content of the 'HashSet' -- and 'Model' -> Bool -- ^ True if the functions are -- equivalent eq_ f g = (Set.toAscList . f) `eq` (toAscList . g) ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests ------------------------------------------------------------------------ -- * Helpers toAscList :: Ord a => S.HashSet a -> [a] toAscList = L.sort . S.toList unordered-containers-0.2.3.0/tests/Regressions.hs0000644000000000000000000000431012062470243020171 0ustar0000000000000000module Main where import Control.Applicative ((<$>)) import Control.Monad (replicateM) import qualified Data.HashMap.Strict as HM import Data.List (delete) import Data.Maybe import Test.HUnit (Assertion, assert) import Test.Framework (Test, defaultMain) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck issue32 :: Assertion issue32 = assert $ isJust $ HM.lookup 7 m' where ns = [0..16] :: [Int] m = HM.fromList (zip ns (repeat [])) m' = HM.delete 10 m ------------------------------------------------------------------------ -- Issue #39 -- First regression issue39 :: Assertion issue39 = assert $ hm1 == hm2 where hm1 = HM.fromList ([a, b] `zip` [1, 1 :: Int ..]) hm2 = HM.fromList ([b, a] `zip` [1, 1 :: Int ..]) a = (1, -1) :: (Int, Int) b = (-1, 1) :: (Int, Int) -- Second regression newtype Keys = Keys [Int] deriving Show instance Arbitrary Keys where arbitrary = sized $ \l -> do pis <- replicateM (l+1) positiveInt return (Keys $ prefixSum pis) shrink (Keys ls) = let l = length ls in if l == 1 then [] else [ Keys (dropAt i ls) | i <- [0..l-1] ] positiveInt :: Gen Int positiveInt = (+1) . abs <$> arbitrary prefixSum :: [Int] -> [Int] prefixSum = loop 0 where loop _ [] = [] loop prefix (l:ls) = let n = l + prefix in n : loop n ls dropAt :: Int -> [a] -> [a] dropAt _ [] = [] dropAt i (l:ls) | i == 0 = ls | otherwise = l : dropAt (i-1) ls propEqAfterDelete :: Keys -> Bool propEqAfterDelete (Keys keys) = let keyMap = mapFromKeys keys k = head keys in HM.delete k keyMap == mapFromKeys (delete k keys) mapFromKeys :: [Int] -> HM.HashMap Int () mapFromKeys keys = HM.fromList (zip keys (repeat ())) ------------------------------------------------------------------------ -- * Test list tests :: [Test] tests = [ testCase "issue32" issue32 , testCase "issue39a" issue39 , testProperty "issue39b" propEqAfterDelete ] ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests unordered-containers-0.2.3.0/tests/Strictness.hs0000644000000000000000000001003512062470243020030 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Data.Hashable (Hashable(hashWithSalt)) import Test.ChasingBottoms.IsBottom import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary(arbitrary)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -- Key type that generates more hash collisions. newtype Key = K { unK :: Int } deriving (Arbitrary, Eq, Ord, Show) instance Hashable Key where hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) => Arbitrary (HashMap k v) where arbitrary = HM.fromList `fmap` arbitrary instance Show (Int -> Int) where show _ = "" instance Show (Int -> Int -> Int) where show _ = "" ------------------------------------------------------------------------ -- * Properties ------------------------------------------------------------------------ -- ** Strict module pSingletonKeyStrict :: Int -> Bool pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v pSingletonValueStrict :: Key -> Bool pSingletonValueStrict k = isBottom $ (HM.singleton k (bottom :: Int)) pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m pLookupDefaultValueStrict :: Key -> HashMap Key Int -> Bool pLookupDefaultValueStrict k m = isBottom $ HM.lookupDefault bottom k m pAdjustKeyStrict :: (Int -> Int) -> HashMap Key Int -> Bool pAdjustKeyStrict f m = isBottom $ HM.adjust f bottom m pAdjustValueStrict :: Key -> HashMap Key Int -> Bool pAdjustValueStrict k m | k `HM.member` m = isBottom $ HM.adjust (const bottom) k m | otherwise = case HM.keys m of [] -> True (k':_) -> isBottom $ HM.adjust (const bottom) k' m pInsertKeyStrict :: Int -> HashMap Key Int -> Bool pInsertKeyStrict v m = isBottom $ HM.insert bottom v m pInsertValueStrict :: Key -> HashMap Key Int -> Bool pInsertValueStrict k m = isBottom $ HM.insert k bottom m pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> HashMap Key Int -> Bool pInsertWithKeyStrict f v m = isBottom $ HM.insertWith f bottom v m pInsertWithValueStrict :: (Int -> Int -> Int) -> Key -> Int -> HashMap Key Int -> Bool pInsertWithValueStrict f k v m | HM.member k m = isBottom $ HM.insertWith (const2 bottom) k v m | otherwise = isBottom $ HM.insertWith f k bottom m ------------------------------------------------------------------------ -- * Test list tests :: [Test] tests = [ -- Basic interface testGroup "HashMap.Strict" [ testProperty "singleton is key-strict" pSingletonKeyStrict , testProperty "singleton is value-strict" pSingletonValueStrict , testProperty "member is key-strict" $ keyStrict HM.member , testProperty "lookup is key-strict" $ keyStrict HM.lookup , testProperty "lookupDefault is key-strict" pLookupDefaultKeyStrict , testProperty "lookupDefault is value-strict" pLookupDefaultValueStrict , testProperty "! is key-strict" $ keyStrict (flip (HM.!)) , testProperty "delete is key-strict" $ keyStrict HM.delete , testProperty "adjust is key-strict" pAdjustKeyStrict , testProperty "adjust is value-strict" pAdjustValueStrict , testProperty "insert is key-strict" pInsertKeyStrict , testProperty "insert is value-strict" pInsertValueStrict , testProperty "insertWith is key-strict" pInsertWithKeyStrict , testProperty "insertWith is value-strict" pInsertWithValueStrict ] ] ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests ------------------------------------------------------------------------ -- * Utilities keyStrict :: (Key -> HashMap Key Int -> a) -> HashMap Key Int -> Bool keyStrict f m = isBottom $ f bottom m const2 :: a -> b -> c -> a const2 x _ _ = x