hamtmap (empty) → 0.2
raw patch · 9 files changed
+1164/−0 lines, 9 filesdep +arraydep +basedep +deepseqsetup-changed
Dependencies added: array, base, deepseq
Files
- Data/BitUtil.hs +287/−0
- Data/HamtMap.hs +525/−0
- LICENSE +24/−0
- README.md +103/−0
- Setup.hs +3/−0
- benchmarks/benchmark.hs +58/−0
- benchmarks/benchmarkmap.hs +59/−0
- hamtmap.cabal +26/−0
- tests/tests.hs +79/−0
+ Data/BitUtil.hs view
@@ -0,0 +1,287 @@+module Data.BitUtil where++import Data.Bits+import Data.Word+import Data.Int++-- Bit operations++-- Given a bitmap and a subhash, this function returns the index into the list+fromBitmap :: (Integral b, Integral c) => Int32 -> b -> c+fromBitmap bitmap subHash =+ let mask = fromIntegral (pred (toBitmap subHash :: Word32)) :: Int32+ in bitCount32 $ bitmap .&. mask++toBitmap :: (Bits t, Integral a) => a -> t+toBitmap subHash = 1 `shiftL` fromIntegral subHash++bitmapToIndices :: (Bits a, Num b) => a -> [b]+bitmapToIndices bitmap = loop 0 bitmap+ where loop _ 0 = []+ loop 32 _ = []+ loop ix bitmap | bitmap .&. 1 == 0 = loop (ix+1) (bitmap `shiftR` 1)+ | otherwise = ix:(loop (ix+1) (bitmap `shiftR` 1))++bitCount32 :: (Integral a) => Int32 -> a+bitCount32 x = bitCount8 ((x `shiftR` 24) .&. 0xff) ++ bitCount8 ((x `shiftR` 16) .&. 0xff) ++ bitCount8 ((x `shiftR` 8) .&. 0xff) ++ bitCount8 (x .&. 0xff)++bitCount8 :: (Bits a, Integral b) => a -> b+bitCount8 0 = 0+bitCount8 1 = 1+bitCount8 2 = 1+bitCount8 3 = 2+bitCount8 4 = 1+bitCount8 5 = 2+bitCount8 6 = 2+bitCount8 7 = 3+bitCount8 8 = 1+bitCount8 9 = 2+bitCount8 10 = 2+bitCount8 11 = 3+bitCount8 12 = 2+bitCount8 13 = 3+bitCount8 14 = 3+bitCount8 15 = 4+bitCount8 16 = 1+bitCount8 17 = 2+bitCount8 18 = 2+bitCount8 19 = 3+bitCount8 20 = 2+bitCount8 21 = 3+bitCount8 22 = 3+bitCount8 23 = 4+bitCount8 24 = 2+bitCount8 25 = 3+bitCount8 26 = 3+bitCount8 27 = 4+bitCount8 28 = 3+bitCount8 29 = 4+bitCount8 30 = 4+bitCount8 31 = 5+bitCount8 32 = 1+bitCount8 33 = 2+bitCount8 34 = 2+bitCount8 35 = 3+bitCount8 36 = 2+bitCount8 37 = 3+bitCount8 38 = 3+bitCount8 39 = 4+bitCount8 40 = 2+bitCount8 41 = 3+bitCount8 42 = 3+bitCount8 43 = 4+bitCount8 44 = 3+bitCount8 45 = 4+bitCount8 46 = 4+bitCount8 47 = 5+bitCount8 48 = 2+bitCount8 49 = 3+bitCount8 50 = 3+bitCount8 51 = 4+bitCount8 52 = 3+bitCount8 53 = 4+bitCount8 54 = 4+bitCount8 55 = 5+bitCount8 56 = 3+bitCount8 57 = 4+bitCount8 58 = 4+bitCount8 59 = 5+bitCount8 60 = 4+bitCount8 61 = 5+bitCount8 62 = 5+bitCount8 63 = 6+bitCount8 64 = 1+bitCount8 65 = 2+bitCount8 66 = 2+bitCount8 67 = 3+bitCount8 68 = 2+bitCount8 69 = 3+bitCount8 70 = 3+bitCount8 71 = 4+bitCount8 72 = 2+bitCount8 73 = 3+bitCount8 74 = 3+bitCount8 75 = 4+bitCount8 76 = 3+bitCount8 77 = 4+bitCount8 78 = 4+bitCount8 79 = 5+bitCount8 80 = 2+bitCount8 81 = 3+bitCount8 82 = 3+bitCount8 83 = 4+bitCount8 84 = 3+bitCount8 85 = 4+bitCount8 86 = 4+bitCount8 87 = 5+bitCount8 88 = 3+bitCount8 89 = 4+bitCount8 90 = 4+bitCount8 91 = 5+bitCount8 92 = 4+bitCount8 93 = 5+bitCount8 94 = 5+bitCount8 95 = 6+bitCount8 96 = 2+bitCount8 97 = 3+bitCount8 98 = 3+bitCount8 99 = 4+bitCount8 100 = 3+bitCount8 101 = 4+bitCount8 102 = 4+bitCount8 103 = 5+bitCount8 104 = 3+bitCount8 105 = 4+bitCount8 106 = 4+bitCount8 107 = 5+bitCount8 108 = 4+bitCount8 109 = 5+bitCount8 110 = 5+bitCount8 111 = 6+bitCount8 112 = 3+bitCount8 113 = 4+bitCount8 114 = 4+bitCount8 115 = 5+bitCount8 116 = 4+bitCount8 117 = 5+bitCount8 118 = 5+bitCount8 119 = 6+bitCount8 120 = 4+bitCount8 121 = 5+bitCount8 122 = 5+bitCount8 123 = 6+bitCount8 124 = 5+bitCount8 125 = 6+bitCount8 126 = 6+bitCount8 127 = 7+bitCount8 128 = 1+bitCount8 129 = 2+bitCount8 130 = 2+bitCount8 131 = 3+bitCount8 132 = 2+bitCount8 133 = 3+bitCount8 134 = 3+bitCount8 135 = 4+bitCount8 136 = 2+bitCount8 137 = 3+bitCount8 138 = 3+bitCount8 139 = 4+bitCount8 140 = 3+bitCount8 141 = 4+bitCount8 142 = 4+bitCount8 143 = 5+bitCount8 144 = 2+bitCount8 145 = 3+bitCount8 146 = 3+bitCount8 147 = 4+bitCount8 148 = 3+bitCount8 149 = 4+bitCount8 150 = 4+bitCount8 151 = 5+bitCount8 152 = 3+bitCount8 153 = 4+bitCount8 154 = 4+bitCount8 155 = 5+bitCount8 156 = 4+bitCount8 157 = 5+bitCount8 158 = 5+bitCount8 159 = 6+bitCount8 160 = 2+bitCount8 161 = 3+bitCount8 162 = 3+bitCount8 163 = 4+bitCount8 164 = 3+bitCount8 165 = 4+bitCount8 166 = 4+bitCount8 167 = 5+bitCount8 168 = 3+bitCount8 169 = 4+bitCount8 170 = 4+bitCount8 171 = 5+bitCount8 172 = 4+bitCount8 173 = 5+bitCount8 174 = 5+bitCount8 175 = 6+bitCount8 176 = 3+bitCount8 177 = 4+bitCount8 178 = 4+bitCount8 179 = 5+bitCount8 180 = 4+bitCount8 181 = 5+bitCount8 182 = 5+bitCount8 183 = 6+bitCount8 184 = 4+bitCount8 185 = 5+bitCount8 186 = 5+bitCount8 187 = 6+bitCount8 188 = 5+bitCount8 189 = 6+bitCount8 190 = 6+bitCount8 191 = 7+bitCount8 192 = 2+bitCount8 193 = 3+bitCount8 194 = 3+bitCount8 195 = 4+bitCount8 196 = 3+bitCount8 197 = 4+bitCount8 198 = 4+bitCount8 199 = 5+bitCount8 200 = 3+bitCount8 201 = 4+bitCount8 202 = 4+bitCount8 203 = 5+bitCount8 204 = 4+bitCount8 205 = 5+bitCount8 206 = 5+bitCount8 207 = 6+bitCount8 208 = 3+bitCount8 209 = 4+bitCount8 210 = 4+bitCount8 211 = 5+bitCount8 212 = 4+bitCount8 213 = 5+bitCount8 214 = 5+bitCount8 215 = 6+bitCount8 216 = 4+bitCount8 217 = 5+bitCount8 218 = 5+bitCount8 219 = 6+bitCount8 220 = 5+bitCount8 221 = 6+bitCount8 222 = 6+bitCount8 223 = 7+bitCount8 224 = 3+bitCount8 225 = 4+bitCount8 226 = 4+bitCount8 227 = 5+bitCount8 228 = 4+bitCount8 229 = 5+bitCount8 230 = 5+bitCount8 231 = 6+bitCount8 232 = 4+bitCount8 233 = 5+bitCount8 234 = 5+bitCount8 235 = 6+bitCount8 236 = 5+bitCount8 237 = 6+bitCount8 238 = 6+bitCount8 239 = 7+bitCount8 240 = 4+bitCount8 241 = 5+bitCount8 242 = 5+bitCount8 243 = 6+bitCount8 244 = 5+bitCount8 245 = 6+bitCount8 246 = 6+bitCount8 247 = 7+bitCount8 248 = 5+bitCount8 249 = 6+bitCount8 250 = 6+bitCount8 251 = 7+bitCount8 252 = 6+bitCount8 253 = 7+bitCount8 254 = 7+bitCount8 255 = 8
+ Data/HamtMap.hs view
@@ -0,0 +1,525 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HamtMap+-- Copyright : (c) Kevin Wu Won 2011+-- License : BSD-style+-- Maintainer : exclipy@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- An implementation of maps from keys to values (dictionaries) based on the+-- hash array mapped trie.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import qualified Data.HamtMap as HM+--+-- This data structure is based on Phil Bagwell's hash array mapped trie,+-- which is described by his original paper:+--+-- * <http://lampwww.epfl.ch/papers/idealhashtrees.pdf>+-----------------------------------------------------------------------------++module Data.HamtMap (+ -- * HamtMap type+ HamtMap+ -- * Operators+ , (Data.HamtMap.!)+ -- * Query+ , member+ , notMember+ , Data.HamtMap.lookup+ -- * Construction+ , empty+ , singleton+ -- * Insertion+ , insert+ , insertWith+ -- * Delete\/Update+ , Data.HamtMap.delete+ , adjust+ , update+ , alter+ -- * Traversal+ , Data.HamtMap.map+ , mapWithKey+ -- * Conversion+ , Data.HamtMap.elems+ , keys+ , toList+ , fromListWith+ , fromList+ ) where++import Data.BitUtil+import Control.Monad+import Control.DeepSeq+import Data.Bits+import Data.Int+import Data.List hiding (insert, lookup)+import Data.Array as A+import Prelude as P++-- | A HamtMap from keys @k@ to values @v@+data (Eq k) => HamtMap k v = HM {+ hashFn :: k -> Int32+ , root :: Node k v+ }++instance (Eq k, Show k, Show v) => Show (HamtMap k v) where+ show (HM h r) = show r+ -- show = ("fromList hashFn "++).show.(Data.HamtMap.toList)++instance (Eq k, NFData k, NFData v) => NFData (HamtMap k v) where+ rnf (HM f r) = f `seq` rnf r++instance (Eq k, NFData k, NFData v) => NFData (Node k v) where+ rnf EmptyNode = ()+ rnf (LeafNode h k v) = rnf h `seq` rnf k `seq` rnf v+ rnf (HashCollisionNode h xs) = rnf h `seq` rnf xs+ rnf (BitmapIndexedNode bm arr) = rnf bm `seq` rnf arr+ rnf (ArrayNode n arr) = rnf n `seq` rnf arr++data (Eq k) => Node k v = EmptyNode |+ LeafNode {+ hash :: Int32+ , key :: k+ , value :: v+ } |+ HashCollisionNode {+ hash :: Int32+ , pairs :: [(k, v)]+ } |+ BitmapIndexedNode {+ bitmap :: Int32+ , subNodes :: Array Int32 (Node k v)+ } |+ ArrayNode {+ numChildren :: Int32+ , subNodes :: Array Int32 (Node k v)+ }++instance (Eq k, Show k, Show v) => Show (Node k v) where+ show EmptyNode = ""+ show (LeafNode _hash key value) = show (key, value)+ show (HashCollisionNode _hash pairs) = "h" ++ show pairs+ show (BitmapIndexedNode bitmap subNodes) = "b" ++ show bitmap ++ (show $ A.elems subNodes)+ show (ArrayNode numChildren subNodes) = "a" ++ show numChildren ++ (show $ A.elems subNodes)+++-- Some constants+shiftStep = 5+chunk = 2^shiftStep+mask = pred chunk+bmnodeMax = 16 -- maximum size of a BitmapIndexedNode+arraynodeMin = 8 -- minimum size of an ArrayNode++-- Some miscellaneous helper functions++isEmptyNode :: Node k v -> Bool+isEmptyNode EmptyNode = True+isEmptyNode _ = False++hashFragment shift hash = (hash `shiftR` shift) .&. fromIntegral mask+++-- | @('empty' hashFn)@ is the empty HamtMap, with hashFn being the key hash function.+empty :: (Eq k) => (k -> Int32) -> HamtMap k v++empty hashFn = HM hashFn EmptyNode+++-- | @('singleton' hashFn key value)@ is a single-element HamtMap holding @(key, value)@+singleton :: (Eq k) => (k -> Int32) -> k -> v -> HamtMap k v++singleton hashFn key value = HM hashFn $ LeafNode (hashFn key) key value+++-- Helper data type for alterNode+data Change = Removed | Modified | Nil | Added deriving Eq+++-- | The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Eq k) => (Maybe v -> Maybe v) -> k -> HamtMap k v -> HamtMap k v++alter updateFn key (HM hashFn root) =+ HM hashFn $ alterNode 0 updateFn (hashFn key) key root+++alterNode :: (Eq k) => Int -> (Maybe v -> Maybe v) -> Int32 -> k -> Node k v -> Node k v++alterNode _shift updateFn hash key EmptyNode =+ maybe EmptyNode+ (LeafNode hash key)+ (updateFn Nothing)++alterNode shift updateFn hash' key' node@(LeafNode hash key value) =+ if key' == key+ then maybe EmptyNode+ (LeafNode hash key)+ (updateFn (Just value))+ else let node' = alterNode shift updateFn hash' key' EmptyNode+ in if isEmptyNode node'+ then node+ else combineNodes shift node node'+ where+ combineNodes :: (Eq k) => Int -> Node k v -> Node k v -> Node k v+ combineNodes shift node1@(LeafNode h1 k1 v1) node2@(LeafNode h2 k2 v2) =+ let hash1 = nodeHash node1+ hash2 = nodeHash node2+ subHash1 = hashFragment shift hash1+ subHash2 = hashFragment shift hash2+ (nodeA, nodeB) = if (subHash1 < subHash2)+ then (node1, node2)+ else (node2, node1)+ bitmap' = ((toBitmap subHash1) .|. (toBitmap subHash2))+ subNodes' = if subHash1 == subHash2+ then listArray (0, 0) [combineNodes (shift+shiftStep) node1 node2]+ else listArray (0, 1) [nodeA, nodeB]+ in if hash1 == hash2+ then HashCollisionNode hash1 [(k2, v2), (k1, v1)]+ else BitmapIndexedNode bitmap' subNodes'+ nodeHash (LeafNode hash key value) = hash+ nodeHash (HashCollisionNode hash pairs) = hash++alterNode _shift updateFn _hash' key (HashCollisionNode hash pairs) =+ let pairs' = updateList updateFn key pairs+ in case pairs' of+ [] -> undefined -- should never happen+ [(key, value)] -> LeafNode hash key value+ otherwise -> HashCollisionNode hash pairs'+ where updateList updateFn key [] =+ maybe []+ (\value' -> [(key, value')])+ (updateFn Nothing)+ updateList updateFn key' ((key, value):pairs) | key' == key =+ maybe pairs+ (\value' -> (key, value'):pairs)+ (updateFn (Just value))+ updateList updateFn key (p:pairs) =+ p : updateList updateFn key pairs++alterNode shift updateFn hash key bmnode@(BitmapIndexedNode bitmap subNodes) =+ let subHash = hashFragment shift hash+ ix = fromBitmap bitmap subHash+ bit = toBitmap subHash+ exists = (bitmap .&. bit) /= 0+ child = if exists then subNodes A.! fromIntegral ix else EmptyNode+ child' = alterNode (shift+shiftStep) updateFn hash key child+ removed = exists && isEmptyNode child'+ added = not exists && not (isEmptyNode child')+ change = if exists+ then if isEmptyNode child'+ then Removed+ else Modified+ else if isEmptyNode child'+ then Nil+ else Added+ bound = snd $ bounds subNodes+ bound' = case change of+ Removed -> bound-1+ Modified -> bound+ Nil -> bound+ Added -> bound+1+ (left, right) = splitAt ix $ A.elems subNodes+ subNodes' = case change of+ Removed -> listArray (0, bound') $ left ++ (tail right)+ Modified -> subNodes // [(fromIntegral ix, child')]+ Nil -> subNodes+ Added -> listArray (0, bound') $ left ++ (child':right)+ bitmap' = case change of+ Removed -> bitmap .&. (complement bit)+ Modified -> bitmap+ Nil -> bitmap+ Added -> bitmap .|. bit+ in if bitmap' == 0+ then -- Remove an empty BitmapIndexedNode+ -- Note: it's possible to have a single-element BitmapIndexedNode+ -- if there are two keys with the same subHash in the trie.+ EmptyNode+ else if bound' == 0 && isLeafNode (subNodes' A.! 0)+ then -- Pack a BitmapIndexedNode into a LeafNode+ subNodes' A.! 0+ else if change == Added && bound' > bmnodeMax - 1+ then -- Expand a BitmapIndexedNode into an ArrayNode+ expandBitmapNode shift subHash child' bitmap subNodes+ else BitmapIndexedNode bitmap' subNodes'+ where+ isLeafNode (LeafNode _ _ _) = True+ isLeafNode _ = False++ expandBitmapNode :: (Eq k) =>+ Int -> Int32 -> Node k v -> Int32 -> Array Int32 (Node k v) -> Node k v+ expandBitmapNode shift subHash node' bitmap subNodes =+ let assocs = zip (bitmapToIndices bitmap) (A.elems subNodes)+ assocs' = (subHash, node'):assocs+ blank = listArray (0, 31) $ replicate 32 EmptyNode+ numChildren = (bitCount32 bitmap) + 1+ in ArrayNode numChildren $ blank // assocs'+ -- TODO: an array copy could be avoided here++alterNode shift updateFn hash key node@(ArrayNode numChildren subNodes) =+ let subHash = hashFragment shift hash+ child = subNodes A.! subHash+ child' = alterNode (shift+shiftStep) updateFn hash key child+ change = if isEmptyNode child+ then if isEmptyNode child'+ then Nil+ else Added+ else if isEmptyNode child'+ then Removed+ else Modified+ numChildren' = case change of+ Removed -> numChildren-1+ Modified -> numChildren+ Nil -> numChildren+ Added -> numChildren+1+ in if numChildren' < arraynodeMin+ -- Pack an ArrayNode into a BitmapIndexedNode when usage drops below 25%+ then packArrayNode subHash numChildren subNodes+ else ArrayNode numChildren' $ subNodes // [(subHash, child')]+ where+ packArrayNode :: (Eq k) => Int32 -> Int32 -> Array Int32 (Node k v) -> Node k v+ packArrayNode subHashToRemove numChildren subNodes =+ let elems' = P.map (\i -> if i == subHashToRemove+ then EmptyNode+ else subNodes A.! i)+ [0..pred chunk]+ subNodes' = listArray (0, (numChildren-2)) $ filter (not.isEmptyNode) elems'+ listToBitmap = foldr (\on bm -> (bm `shiftL` 1) .|. (if on then 1 else 0)) 0+ bitmap = listToBitmap $ P.map (not.isEmptyNode) elems'+ in BitmapIndexedNode bitmap subNodes'+++-- | Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+insertWith :: (Eq k) => (v -> v -> v) -> k -> v -> HamtMap k v -> HamtMap k v++insertWith accumFn key value hm =+ let fn :: (v -> v -> v) -> v -> Maybe v -> Maybe v+ fn accumFn x' Nothing = Just x'+ fn accumFn x' (Just x) = Just $ accumFn x' x+ in alter (fn accumFn value) key hm+++-- | Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: (Eq k) => k -> v -> HamtMap k v -> HamtMap k v++insert = insertWith const+++-- | The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+update :: (Eq k) => (v -> Maybe v) -> k -> HamtMap k v -> HamtMap k v++update updateFn = alter ((=<<) updateFn)+++-- | Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+delete :: (Eq k) => k -> HamtMap k v -> HamtMap k v++delete = alter (const Nothing)+++-- | Update a value at a specific key with the result of the provided function.+-- When the key is not a member of the map, the original map is returned.+adjust :: (Eq k) => (v -> v) -> k -> HamtMap k v -> HamtMap k v++adjust updateFn = alter ((=<<) ((Just).updateFn))+++-- | Map a function over all values in the map.+mapWithKey :: (Eq k) => (k -> v -> v) -> HamtMap k v -> HamtMap k v++mapWithKey mapFn (HM hashFn root) =+ HM hashFn $ mapWithKeyNode mapFn root+++mapWithKeyNode :: (Eq k) => (k -> v -> v) -> Node k v -> Node k v++mapWithKeyNode _mapFn EmptyNode = EmptyNode++mapWithKeyNode mapFn (LeafNode hash key value) = LeafNode hash key $ mapFn key value++mapWithKeyNode mapFn (HashCollisionNode hash pairs) =+ HashCollisionNode hash (P.map (\(key, value) -> (key, mapFn key value)) pairs)++mapWithKeyNode mapFn (BitmapIndexedNode bitmap subNodes) =+ BitmapIndexedNode bitmap $ arrayMap (mapWithKeyNode mapFn) subNodes++mapWithKeyNode mapFn (ArrayNode numChildren subNodes) =+ ArrayNode numChildren $ arrayMap (mapWithKeyNode mapFn) subNodes+++arrayMap :: (Ix i) => (a -> a) -> Array i a -> Array i a++arrayMap fn arr = array (bounds arr) $ P.map (\(key, value) -> (key, fn value)) $ A.assocs arr+++-- | Map a function over all values in the map.+map :: (Eq k) => (v -> v) -> HamtMap k v -> HamtMap k v++map fn = mapWithKey (const fn)+++-- | Lookup the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+lookup :: (Eq k) => k -> HamtMap k v -> Maybe v++lookup key (HM hashFn root) = lookupNode 0 (hashFn key) key root+++lookupNode :: (Eq k) => Int -> Int32 -> k -> Node k v -> Maybe v++lookupNode _ _ _ EmptyNode = Nothing++lookupNode _ _ key' (LeafNode _ key value) =+ if key' == key then Just value+ else Nothing++lookupNode _ _ key (HashCollisionNode _ pairs) =+ P.lookup key pairs++lookupNode shift hash key (BitmapIndexedNode bitmap subNodes) =+ let subHash = hashFragment shift hash+ ix = fromBitmap bitmap subHash+ exists = (bitmap .&. (toBitmap subHash)) /= 0+ in if exists+ then lookupNode (shift+shiftStep) hash key (subNodes A.! ix)+ else Nothing++lookupNode shift hash key (ArrayNode _numChildren subNodes) =+ let subHash = hashFragment shift hash+ in lookupNode (shift+shiftStep) hash key (subNodes A.! subHash)+++-- | Find the value at a key.+-- Calls 'error' when the element can not be found.+(!) :: (Eq k) => HamtMap k v -> k -> v++hm ! key = maybe (error "element not in the map")+ id+ (Data.HamtMap.lookup key hm)+++-- | Is the key a member of the map? See also 'notMember'.+member :: (Eq k) => k -> HamtMap k v -> Bool++member key hm = maybe False (const True) (Data.HamtMap.lookup key hm)++-- | Is the key a member of the map? See also 'member'.+notMember :: (Eq k) => k -> HamtMap k v -> Bool++notMember key = not.(member key)+++-- | Convert to a list of key\/value pairs.+toList :: (Eq k) => HamtMap k v -> [(k, v)]++toList (HM _hashFn root) = toListNode root+++toListNode :: (Eq k) => Node k v -> [(k, v)]++toListNode EmptyNode = []++toListNode (LeafNode _hash key value) = [(key, value)]++toListNode (HashCollisionNode _hash pairs) = pairs++toListNode (BitmapIndexedNode _bitmap subNodes) =+ concat $ P.map toListNode $ A.elems subNodes++toListNode (ArrayNode _numChildren subNodes) =+ concat $ P.map toListNode $ A.elems subNodes+++-- | Build a map from a list of key\/value pairs with a combining function.+fromListWith :: (Eq k) => (k -> Int32) -> (v -> v -> v) -> [(k, v)] -> HamtMap k v++fromListWith hashFn combineFn assocs =+ HM hashFn $ fromListNode 0 combineFn $ P.map (\(k, v) -> ((hashFn k), k, v)) assocs+++fromListNode :: (Eq k) => Int -> (v -> v -> v) -> [(Int32, k, v)] -> Node k v++fromListNode shift combineFn hkvs =+ let subHashed = P.map (\triple@(h, k, v) -> (hashFragment shift h, triple)) hkvs+ divided = accumArray (flip (:)) [] (0, mask) subHashed+ -- this will alternately reverse and unreverse the list on each level down+ dividedList = A.elems divided+ subNodes = listArray (0, mask) $ P.map (fromListNode (shift+shiftStep) combineFn) $ dividedList+ numChildren = length $ filter (not.null) dividedList+ in case hkvs of+ [] -> EmptyNode+ [(h, k, v)] -> LeafNode h k v+ (h, k, v):hkvs' | all (\(h', _, _) -> h' == h) hkvs' ->+ if all (\(_, k', _) -> k' == k) hkvs'+ then let combineFn' = if even shift then flip combineFn else combineFn+ -- correct for the alternate reversing of the list+ v' = foldl1' combineFn' (P.map (\(_, _, v) -> v) hkvs)+ in LeafNode h k v'+ else let keyCmp (k1, _) (k2, _) = k1 == k2+ collisions = P.map (\(_, k', v') -> (k', v')) hkvs+ grouped = groupBy' keyCmp collisions+ combineFn' = if even shift then flip combineFn else combineFn+ collisionKeys = P.map (fst.head) grouped+ collisionVals = P.map ((foldl1' combineFn').(P.map snd)) grouped+ collisions' = zip collisionKeys collisionVals+ in HashCollisionNode h collisions'+ _ | numChildren > fromIntegral bmnodeMax ->+ ArrayNode (fromIntegral numChildren) subNodes+ _ | otherwise ->+ makeBMNode numChildren subNodes+ where+ makeBMNode :: (Eq k) => Int -> Array Int32 (Node k v) -> Node k v+ makeBMNode numChildren subNodes =+ let subNodeList = A.elems subNodes+ subNodes' = listArray (0, (fromIntegral numChildren-1)) $ filter (not.isEmptyNode) subNodeList+ listToBitmap = foldr (\on bm -> (bm `shiftL` 1) .|. (if on then 1 else 0)) 0+ bitmap = listToBitmap $ P.map (not.isEmptyNode) subNodeList+ in BitmapIndexedNode bitmap subNodes'++ -- groupBy' is like Data.List.groupBy, but also groups non-adjacent elements+ groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]+ groupBy' eq list = P.map reverse $ foldl' (insertGrouped eq) [] list++ insertGrouped :: (a -> a -> Bool) -> [[a]] -> a -> [[a]]+ insertGrouped eq [] y = [[y]]+ insertGrouped eq ((x:xs):gs) y | eq x y = (y:x:xs) : gs+ | otherwise = (x:xs) : insertGrouped eq gs y+++-- | Build a map from a list of key\/value pairs.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromList :: (Eq k) => (k -> Int32) -> [(k, v)] -> HamtMap k v++fromList hashFn assocs =+ fromListWith hashFn const assocs++++-- | Return all keys of the map.+keys :: (Eq k) => HamtMap k v -> [k]++keys = (P.map fst).toList+++-- | Return all elements of the map.+elems :: (Eq k) => HamtMap k v -> [v]++elems = (P.map snd).toList
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright 2011, Kevin Wu Won.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. 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.+3. The name of the author may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ README.md view
@@ -0,0 +1,103 @@+Hash Array Mapped Tries+=======================++One of the prominent features of the [Clojure][1] language are a set of+[immutable data structures][2] with efficient manipulation operations. One of+the most innovative and important is the persistent hash map based on the+*hash array mapped trie* (HAMT).++This project is a port of this structure to Haskell, as Data.HamtMap. The+interface has been kept as consistent as possible with Data.Map.++[1]: http://clojure.org/+[2]: http://clojure.org/datatypes+++Basic usage+-----------+Here's a demo of what you can do with a HamtMap:++ ghci> :m + Data.HamtMap+ ghci> empty Data.HashTable.hashString+ -- an empty HamtMap (requires a key hash function)+ fromList hashFn []++ ghci> insert "foo" 1 it+ fromList hashFn [("foo",1)]++ ghci> insert "bar" 42 it+ fromList hashFn [("foo",1),("bar",42)]++ ghci> insert "qux" 123 it+ fromList hashFn [("qux",12),("foo",1),("bar",42)]++ ghci> insert "qux" 13 it -- inserting an existing key overwrites by default+ fromList hashFn [("qux",13),("foo",1),("bar",42)]++ ghci> let a = it+ ghci> a ! "foo"+ 1++ ghci> a ! "baz" -- using (!) is unsafe+ *** Exception: array index out of range: element not in the map++ ghci> Data.HamtMap.lookup "bar" a+ Just 42++ ghci> Data.HamtMap.lookup "baz" a -- 'lookup' returns a safe Maybe+ Nothing++ ghci> adjust succ "foo" a -- apply a function to a value+ fromList hashFn [("qux",13),("foo",2),("bar",42)]++ ghci> Data.HamtMap.map succ a -- apply a function to all values+ fromList hashFn [("qux",14),("foo",2),("bar",43)]++ ghci> keys a+ ["qux","foo","bar"]++ ghci> elems a+ [13,1,42]++ ghci> fromList Data.HashTable.hashString [("a", 1), ("b", 2), ("c", 3)]+ fromList hashFn [("b",2),("c",3),("a",1)]++ ghci> toList it+ [("b",2),("c",3),("a",1)]+++Installation+------------++To try it yourself, just do the usual:++ $ runghc Setup.hs configure --user+ $ runghc Setup.hs build+ $ runghc Setup.hs install++Performance+-----------++The single-element operations for the hash map have logarithmic asymtotic+runtime complexity. However, it is implemented as a 32-ary tree, which means it+never exceeds a depth of 7 nodes, so you can treat them as constant-time+operations (for relatively large constants).++How it works+------------++I wrote this code after reading the following explanatory blog posts on how the+Clojure version works. They should also provide a decent birds-eye overview of+my Haskell implementation.++* [Understanding Clojure’s PersistentHashMap+ ](http://blog.higher-order.net/2009/09/08/understanding-clojures-persistenthashmap-deftwice/)+* [Assoc and Clojure’s PersistentHashMap: part II+ ](http://blog.higher-order.net/2010/08/16/assoc-and-clojures-persistenthashmap-part-ii/)+++To do+-----+* Match Data.Map in completeness+* Performance tuning+ * Efficient implementations of (//), etc. based on fromList
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/runhaskell+import Distribution.Simple+main = defaultMain
+ benchmarks/benchmark.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE GADTs #-}++module Main where++import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad.Trans (liftIO)+import Criterion.Config+import Criterion.Main+import Data.Hashable (Hashable(hash))+import Data.Int (Int32)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C+import qualified Data.HamtMap as HM+import Data.List (foldl')+import Data.Maybe (fromMaybe)+import Prelude hiding (lookup)+import System.Random (mkStdGen, randomRs)++instance NFData BS.ByteString++hashBS :: BS.ByteString -> Int32+hashBS = fromIntegral . hash++main :: IO ()+main = do+ let hmbs = HM.fromList hashBS elemsBS :: HM.HamtMap BS.ByteString Int+ defaultMainWith defaultConfig+ (liftIO . evaluate $ rnf [hmbs])+ [ bench "fromList" $ nf (HM.fromList hashBS) elemsBS+ , bench "lookup" $ nf (lookup keysBS) hmbs+ , bench "insert" $ nf (insert elemsBS) (HM.empty hashBS)+ , bench "delete" $ nf (delete keysBS) hmbs+ ]+ where+ n :: Int+ n = 2^(12 :: Int)++ elemsBS = zip keysBS [1..n]+ keysBS = rnd 8 n++lookup :: Eq k => [k] -> HM.HamtMap k Int -> Int+lookup xs m = foldl' (\z k -> fromMaybe z (HM.lookup k m)) 0 xs++insert :: Eq k => [(k, Int)] -> HM.HamtMap k Int -> HM.HamtMap k Int+insert xs m0 = foldl' (\m (k, v) -> HM.insert k v m) m0 xs++delete :: Eq k => [k] -> HM.HamtMap k Int -> HM.HamtMap k Int+delete xs m0 = foldl' (\m k -> HM.delete k m) m0 xs++-- | Generate a number of fixed length strings where the content of+-- the strings are letters in random order.+rnd :: Int -- ^ Length of each string+ -> Int -- ^ Number of strings+ -> [BS.ByteString]+rnd strlen num = map C.pack $ take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234+ where+ split cs = case splitAt strlen cs of (str, cs') -> str : split cs'
+ benchmarks/benchmarkmap.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GADTs #-}++module Main where++import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad.Trans (liftIO)+import Criterion.Config+import Criterion.Main+import Data.Hashable (Hashable(hash))+import Data.Int (Int32)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C+import qualified Data.Map as M+import Data.List (foldl')+import Data.Maybe (fromMaybe)+import Prelude hiding (lookup)+import System.Random (mkStdGen, randomRs)++instance NFData BS.ByteString++hashBS :: BS.ByteString -> Int32+hashBS = fromIntegral . hash++main :: IO ()+main = do+ let hmbs = M.fromList elemsBS :: M.Map BS.ByteString Int+ defaultMainWith defaultConfig+ (liftIO . evaluate $ rnf [hmbs])+ [ bench "fromList" $ nf M.fromList elemsBS+ , bench "lookup" $ nf (lookup keysBS) hmbs+ , bench "insert" $ nf (insert elemsBS) (M.empty)+ , bench "delete" $ nf (delete keysBS) hmbs+ ]+ where+ n :: Int+ n = 2^(12 :: Int)++ elemsBS = zip keysBS [1..n]+ keysBS = rnd 8 n++lookup :: Ord k => [k] -> M.Map k Int -> Int+lookup xs m = foldl' (\z k -> fromMaybe z (M.lookup k m)) 0 xs++insert :: Ord k => [(k, Int)] -> M.Map k Int -> M.Map k Int+insert xs m0 = foldl' (\m (k, v) -> M.insert k v m) m0 xs++delete :: Ord k => [k] -> M.Map k Int -> M.Map k Int+delete xs m0 = foldl' (\m k -> M.delete k m) m0 xs++-- | Generate a number of fixed length strings where the content of+-- the strings are letters in random order.+rnd :: Int -- ^ Length of each string+ -> Int -- ^ Number of strings+ -> [BS.ByteString]+rnd strlen num = map C.pack $ take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234+ where+ split cs = case splitAt strlen cs of (str, cs') -> str : split cs'+
+ hamtmap.cabal view
@@ -0,0 +1,26 @@+name: hamtmap+version: 0.2+cabal-version: >= 1.2+synopsis: A purely functional and persistent hash map+description: A port of Clojure's efficient persistent and hash+ map data structure to Haskell+license: BSD3+license-File: LICENSE+author: Kevin Wu Won+maintainer: Kevin Wu Won <exclipy@gmail.com>+homepage: https://github.com/exclipy/pdata+category: Data Structures+build-type: Simple+extra-source-files:+ Data/BitUtil.hs+ benchmarks/benchmark.hs+ benchmarks/benchmarkmap.hs+ tests/tests.hs+ README.md+stability: experimental++library+ build-depends: base >= 4 && < 5, array, deepseq+ exposed-modules: Data.HamtMap+ other-modules: Data.BitUtil+ ghc-options: -O2
+ tests/tests.hs view
@@ -0,0 +1,79 @@+import Test.QuickCheck+import Test.QuickCheck.Batch+import Data.Hashable+import Data.HamtMap as HM+import Data.Int+import Data.List (foldl', sort)+import Data.Maybe (isNothing)+import Prelude as P++ldelete :: (Eq k) => k -> [(k, v)] -> [(k, v)]+ldelete _ [] = []+ldelete k ((k', v'):xs) | k' == k = ldelete k xs+ | otherwise = (k', v') : ldelete k xs++lset :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)]+lset k v [] = []+lset k v ((k', v'):xs) | k' == k = (k, v) : lset k v xs+ | otherwise = (k', v') : lset k v xs++prop_insert :: (Eq k, Hashable k, Eq v) => (k -> Int32) -> k -> v -> [(k, v)] -> Bool+prop_insert hashFn k v lm =+ let hm = fromList hashFn lm+ hm' = insert k v hm+ in member k hm'+ && not (notMember k hm')+ && HM.lookup k hm' == Just v+ && hm' ! k == v+ && (if member k hm+ then toList hm == lset k (hm ! k) (toList hm')+ else toList hm == ldelete k (toList hm')+ )++prop_delete :: (Eq k, Hashable k, Eq v) => (k -> Int32) -> k -> [(k, v)] -> Bool+prop_delete hashFn k lm =+ let hm = fromList hashFn lm+ hm' = delete k hm+ in not (member k hm')+ && notMember k hm'+ && isNothing (HM.lookup k hm')+ && (if member k hm+ then toList hm' == ldelete k (toList hm)+ else toList hm' == toList hm+ )++prop_fromList :: (Eq k, Hashable k, Ord k, Eq v, Ord v) => (k -> Int32) -> [(k, v)] -> Bool+prop_fromList hashFn lm =+ let hm = fromList hashFn lm+ hm' = foldl' (\hm (k,v) -> insert k v hm) (empty hashFn) lm+ in sort (toList hm) == sort (toList hm')++prop_toList :: (Eq k, Hashable k, Ord k, Eq v, Ord v) => (k -> Int32) -> [(k, v)] -> Bool+prop_toList hashFn lm =+ let hm = fromList hashFn lm+ lm' = toList hm+ ks = keys hm+ ks' = P.map fst lm'+ els = elems hm+ els' = P.map snd lm'+ els'' = P.map (\k -> hm ! k) ks+ in ks == ks'+ && els == els'+ && els == els''+++options = TestOptions+ { no_of_tests = 200+ , length_of_tests = 2 -- seconds+ , debug_tests = False }++main = runTests "tests" options+ [ run (prop_insert fromIntegral :: Int -> Int -> [(Int,Int)] -> Bool)+ , run (prop_insert (fromIntegral.(`mod` 2)) :: Int -> Int -> [(Int,Int)] -> Bool)+ , run (prop_delete fromIntegral :: Int -> [(Int, Int)] -> Bool)+ , run (prop_delete (fromIntegral.(`mod` 2)) :: Int -> [(Int,Int)] -> Bool)+ , run (prop_fromList fromIntegral :: [(Int, Int)] -> Bool)+ , run (prop_fromList (fromIntegral.(`mod` 2)) :: [(Int, Int)] -> Bool)+ , run (prop_toList fromIntegral :: [(Int, Int)] -> Bool)+ , run (prop_toList (fromIntegral.(`mod` 2)) :: [(Int, Int)] -> Bool)+ ]