diff --git a/Data/CritBit/Core.hs b/Data/CritBit/Core.hs new file mode 100644 --- /dev/null +++ b/Data/CritBit/Core.hs @@ -0,0 +1,152 @@ +-- | +-- Module : Data.CritBit.Tree +-- Copyright : (c) Bryan O'Sullivan 2013 +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- "Core" functions that implement the crit-bit tree algorithms. +-- +-- I plopped these functions into their own source file to demonstrate +-- just how small the core of the crit-bit tree concept is. +-- +-- I have also commented this module a bit more heavily than I usually +-- do, in the hope that the comments will make the code more +-- approachable to less experienced Haskellers. +module Data.CritBit.Core + ( + -- * Public functions + insert + , lookupWith + , delete + -- * Internal functions + , calcDirection + , direction + , followPrefixes + ) where + +import Data.Bits ((.|.), (.&.), complement, shiftR, xor) +import Data.CritBit.Types.Internal +import Data.Word (Word16) + +-- | /O(log n)/. 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 "b" 7 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",7)] +-- > insert "x" 7 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("x",7)] +-- > insert "x" 5 empty == singleton "x" 5 +insert :: (CritBitKey k) => k -> v -> CritBit k v -> CritBit k v +insert k v (CritBit root) = CritBit . go $ root + where + go i@(Internal left right _ _) + | direction k i == 0 = go left + | otherwise = go right + go (Leaf lk _) = rewalk root + where + rewalk i@(Internal left right byte otherBits) + | byte > n = finish i + | byte == n && otherBits > nob = finish i + | direction k i == 0 = i { ileft = rewalk left } + | otherwise = i { iright = rewalk right } + rewalk i = finish i + + finish (Leaf _ _) | k == lk = Leaf lk v + finish node + | nd == 0 = Internal { ileft = node, iright = Leaf k v, + ibyte = n, iotherBits = nob } + | otherwise = Internal { ileft = Leaf k v, iright = node, + ibyte = n, iotherBits = nob } + + (n, nob, c) = followPrefixes k lk + nd = calcDirection nob c + go Empty = Leaf k v +{-# INLINABLE insert #-} + +lookupWith :: (CritBitKey k) => + a -- ^ Failure continuation + -> (v -> a) -- ^ Success continuation + -> k + -> CritBit k v -> a +-- We use continuations here to avoid reimplementing the lookup +-- algorithm with trivial variations. +lookupWith notFound found k (CritBit root) = go root + where + go i@(Internal left right _ _) + | direction k i == 0 = go left + | otherwise = go right + go (Leaf lk v) | k == lk = found v + go _ = notFound +{-# INLINE lookupWith #-} + +-- | /O(log n)/. 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 "a" (fromList [("a",5), ("b",3)]) == singleton "b" 3 +-- > delete "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)] +-- > delete "a" empty == empty +delete :: (CritBitKey k) => k -> CritBit k v -> CritBit k v +-- Once again with the continuations! It's somewhat faster to do +-- things this way than to expicitly unwind our recursion once we've +-- found the leaf to delete. It's also a ton less code. +-- +-- (If you want a good little exercise, rewrite this function without +-- using continuations, and benchmark the two versions.) +delete k t@(CritBit root) = go root CritBit + where + go i@(Internal left right _ _) cont + | direction k i == 0 = go left $ \new -> + case new of + Empty -> cont right + l -> cont $! i { ileft = l } + | otherwise = go right $ \new -> + case new of + Empty -> cont left + r -> cont $! i { iright = r } + go (Leaf lk _) cont + | k == lk = cont Empty + go _ _ = t +{-# INLINABLE delete #-} + +-- | Determine which direction we should move down the tree based on +-- the critical bitmask at the current node and the corresponding byte +-- in the key. Left is 0, right is 1. +direction :: (CritBitKey k) => k -> Node k v -> Int +direction k (Internal _ _ byte otherBits) = + calcDirection otherBits (getByte k byte) +direction _ _ = error "Data.CritBit.Core.direction: unpossible!" +{-# INLINE direction #-} + +-- Given a critical bitmask and a byte, return 0 to move left, 1 to +-- move right. +calcDirection :: BitMask -> Word16 -> Int +calcDirection otherBits c = (1 + fromIntegral (otherBits .|. c)) `shiftR` 9 +{-# INLINE calcDirection #-} + +-- | Figure out the byte offset at which the key we are interested in +-- differs from the leaf we reached when we initially walked the tree. +-- +-- We return some auxiliary stuff that we'll bang on to help us figure +-- out which direction to go in to insert a new node. +followPrefixes :: (CritBitKey k) => + k -- ^ The key from "outside" the tree. + -> k -- ^ Key from the leaf we reached. + -> (Int, BitMask, Word16) +{-# INLINE followPrefixes #-} +followPrefixes k l = go 0 + where + go n | n == byteCount k = (n, maskLowerBits c, c) + | n == byteCount l = (n, maskLowerBits b, 0) + | b /= c = (n, maskLowerBits (b `xor` c), c) + | otherwise = go (n+1) + where b = getByte k n + c = getByte l n + + maskLowerBits v = (n3 .&. (complement (n3 `shiftR` 1))) `xor` 511 + where + n3 = n2 .|. (n2 `shiftR` 8) + n2 = n1 .|. (n1 `shiftR` 4) + n1 = n0 .|. (n0 `shiftR` 2) + n0 = v .|. (v `shiftR` 1) diff --git a/Data/CritBit/Map/Lazy.hs b/Data/CritBit/Map/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/CritBit/Map/Lazy.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Data.CritBit.Map.Lazy +-- Copyright : (c) Bryan O'Sullivan 2013 +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- A crit-bit tree that does not evaluate its values by default. +-- +-- For every /n/ key-value pairs stored, a crit-bit tree uses /n/-1 +-- internal nodes, for a total of 2/n/-1 internal nodes and leaves. +module Data.CritBit.Map.Lazy + ( + -- * Types + CritBitKey(..) + , CritBit + , module Data.CritBit.Tree + ) where + +import Data.CritBit.Tree +import Data.CritBit.Types.Internal diff --git a/Data/CritBit/Tree.hs b/Data/CritBit/Tree.hs new file mode 100644 --- /dev/null +++ b/Data/CritBit/Tree.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE BangPatterns, RecordWildCards, ScopedTypeVariables #-} + +-- | +-- Module : Data.CritBit.Tree +-- Copyright : (c) Bryan O'Sullivan 2013 +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +module Data.CritBit.Tree + ( + -- * Operators + -- , (!) + -- , (\\) + + -- * Query + null + , size + , member + , notMember + , lookup + , findWithDefault + , lookupGT + -- , lookupGE + + -- * Construction + , empty + , singleton + + -- * Insertion + , insert + -- , insertWith + -- , insertWithKey + -- , insertLookupWithKey + + -- * Deletion + , delete + -- , adjust + -- , adjustWithKey + -- , update + -- , updateWithKey + -- , updateLookupWithKey + -- , alter + + -- * Combination + -- ** Union + , union + -- , unionWith + -- , unionWithKey + -- , unions + -- , unionsWith + , unionL + , unionR + + -- ** Difference + -- , difference + -- , differenceWith + -- , differenceWithKey + + -- ** Intersection + -- , intersection + -- , intersectionWith + -- , intersectionWithKey + + -- * Traversal + -- ** Map + -- , map + -- , mapWithKey + -- , traverseWithKey + -- , mapAccum + -- , mapAccumWithKey + -- , mapAccumRWithKey + -- , mapKeys + -- , mapKeysWith + -- , mapKeysMonotonic + + -- * Folds + , foldl + , foldr + , foldlWithKey + , foldrWithKey + + -- ** Strict folds + , foldl' + , foldr' + , foldlWithKey' + , foldrWithKey' + + -- * Conversion + -- , elems + , keys + -- , assocs + -- , keysSet + -- , fromSet + + -- ** Lists + , toList + , fromList + -- , fromListWith + -- , fromListWithKey + + -- ** Ordered lists + -- , toAscList + -- , toDescList + -- , fromAscList + -- , fromAscListWith + -- , fromAscListWithKey + -- , fromDistinctAscList + + -- * Filter + -- , filter + -- , filterWithKey + -- , partition + -- , partitionWithKey + + -- , mapMaybe + -- , mapMaybeWithKey + -- , mapEither + -- , mapEitherWithKey + + -- , split + -- , splitLookup + + -- * Submap + -- , isSubmapOf + -- , isSubmapOfBy + -- , isProperSubmapOf + -- , isProperSubmapOfBy + + -- -- * Min\/Max + -- , findMin + -- , findMax + -- , deleteMin + -- , deleteMax + -- , deleteFindMin + -- , deleteFindMax + -- , updateMin + -- , updateMax + -- , updateMinWithKey + -- , updateMaxWithKey + -- , minView + -- , maxView + -- , minViewWithKey + -- , maxViewWithKey + ) where + +import Data.CritBit.Core +import Data.CritBit.Types.Internal +import Prelude hiding (foldl, foldr, lookup, null) +import qualified Data.List as List + +-- | /O(1)/. Is the map empty? +-- +-- > null (empty) == True +-- > null (singleton 1 'a') == False +null :: CritBit k v -> Bool +null (CritBit Empty) = True +null _ = False + +-- | /O(1)/. The empty map. +-- +-- > empty == fromList [] +-- > size empty == 0 +empty :: CritBit k v +empty = CritBit { cbRoot = Empty } + +-- | /O(log n)/. Is the key a member of the map? +-- +-- > member "a" (fromList [("a",5), ("b",3)]) == True +-- > member "c" (fromList [("a",5), ("b",3)]) == False +-- +-- See also 'notMember'. +member :: (CritBitKey k) => k -> CritBit k v -> Bool +member k m = lookupWith False (const True) k m +{-# INLINABLE member #-} + +-- | /O(log n)/. Is the key not a member of the map? +-- +-- > notMember "a" (fromList [("a",5), ("b",3)]) == False +-- > notMember "c" (fromList [("a",5), ("b",3)]) == True +-- +-- See also 'member'. +notMember :: (CritBitKey k) => k -> CritBit k v -> Bool +notMember k m = lookupWith True (const False) k m +{-# INLINE notMember #-} + +-- | /O(log n)/. 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. +-- +-- An example of using @lookup@: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > import Data.Text +-- > import Prelude hiding (lookup) +-- > import Data.CritBit.Map.Lazy +-- > +-- > employeeDept, deptCountry, countryCurrency :: CritBit Text Text +-- > employeeDept = fromList [("John","Sales"), ("Bob","IT")] +-- > deptCountry = fromList [("IT","USA"), ("Sales","France")] +-- > countryCurrency = fromList [("USA", "Dollar"), ("France", "Euro")] +-- > +-- > employeeCurrency :: Text -> Maybe Text +-- > employeeCurrency name = do +-- > dept <- lookup name employeeDept +-- > country <- lookup dept deptCountry +-- > lookup country countryCurrency +-- > +-- > main = do +-- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John")) +-- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete")) +-- +-- The output of this program: +-- +-- > John's currency: Just "Euro" +-- > Pete's currency: Nothing +lookup :: (CritBitKey k) => k -> CritBit k v -> Maybe v +lookup k m = lookupWith Nothing Just k m +{-# INLINABLE lookup #-} + +-- | /O(log n)/. Returns the value associated with the given key, or +-- the given default value if the key is not in the map. +-- +-- > findWithDefault 1 "x" (fromList [("a",5), ("b",3)]) == 1 +-- > findWithDefault 1 "a" (fromList [("a",5), ("b",3)]) == 5 +findWithDefault :: (CritBitKey k) => + v -- ^ Default value to return if lookup fails. + -> k -> CritBit k v -> v +findWithDefault d k m = lookupWith d id k m +{-# INLINABLE findWithDefault #-} + +-- | /O(log n)/. Find smallest key greater than the given one and +-- return the corresponding (key, value) pair. +-- +-- > lookupGT "aa" (fromList [("a",3), ("b",5)]) == Just ("b",5) +-- > lookupGT "b" (fromList [("a",3), ("b",5)]) == Nothing +lookupGT :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v) +lookupGT k (CritBit root) = go root + where + go i@(Internal left right _ _) + | direction k i == 0 = go left + | otherwise = go right + go (Leaf lk lv) = rewalk root + where + finish (Leaf _ _) = case byteCompare k lk of + LT -> Just (lk, lv) + _ -> Nothing + finish node + | calcDirection nob c == 0 = Nothing + | otherwise = leftmost node + rewalk i@(Internal left right byte otherBits) + | byte > n = finish i + | byte == n && otherBits > nob = finish i + | direction k i == 0 = case rewalk left of + Nothing -> leftmost right + wat -> wat + | otherwise = rewalk right + rewalk i = finish i + (n, nob, c) = followPrefixes k lk + go Empty = Nothing + leftmost (Internal left _ _ _) = leftmost left + leftmost (Leaf lmk lmv) = Just (lmk, lmv) + leftmost _ = Nothing +{-# INLINABLE lookupGT #-} + +byteCompare :: (CritBitKey k) => k -> k -> Ordering +byteCompare a b = go 0 + where + go i = case ba `compare` getByte b i of + EQ | ba /= 0 -> go (i + 1) + wat -> wat + where ba = getByte a i +{-# INLINABLE byteCompare #-} + +-- | /O(n*log n)/. 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 [] == empty +-- > fromList [("a",5), ("b",3), ("a",2)] == fromList [("a",2), ("b",3)] +fromList :: (CritBitKey k) => [(k, v)] -> CritBit k v +fromList = List.foldl' (flip (uncurry insert)) empty +{-# INLINABLE fromList #-} + +-- | /O(1)/. A map with a single element. +-- +-- > singleton "a" 1 == fromList [("a", 1)] +singleton :: k -> v -> CritBit k v +singleton k v = CritBit (Leaf k v) +{-# INLINE singleton #-} + +-- | /O(n)/. The number of elements in the map. +-- +-- > size empty == 0 +-- > size (singleton "a" 1) == 1 +-- > size (fromList [("a",1), ("c",2), ("b",3)]) == 3 +size :: CritBit k v -> Int +size (CritBit root) = go root + where + go (Internal l r _ _) = go l + go r + go (Leaf _ _) = 1 + go Empty = 0 + +-- | /O(n)/. Fold the values in the map using the given +-- left-associative function, such that +-- @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. +-- +-- Examples: +-- +-- > elems = reverse . foldl (flip (:)) [] +-- +-- > foldl (+) 0 (fromList [("a",5), ("bbb",3)]) == 8 +foldl :: (a -> v -> a) -> a -> CritBit k v -> a +foldl f z m = foldlWithKeyWith (\_ b -> b) (\a _ v -> f a v) z m +{-# INLINABLE foldl #-} + +-- | /O(n)/. A strict version of 'foldl'. Each application of the +-- function is evaluated before using the result in the next +-- application. This function is strict in the starting value. +foldl' :: (a -> v -> a) -> a -> CritBit k v -> a +foldl' f z m = foldlWithKeyWith seq (\a _ v -> f a v) z m +{-# INLINABLE foldl' #-} + +-- | /O(n)/. Fold the keys and values in the map using the given +-- left-associative function, such that +-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. +-- +-- Examples: +-- +-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) [] +-- +-- > let f result k a = result ++ "(" ++ show k ++ ":" ++ a ++ ")" +-- > foldlWithKey f "Map: " (fromList [("a",5), ("b",3)]) == "Map: (b:3)(a:5)" +foldlWithKey :: (a -> k -> v -> a) -> a -> CritBit k v -> a +foldlWithKey f z m = foldlWithKeyWith (\_ b -> b) f z m +{-# INLINABLE foldlWithKey #-} + +-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of +-- the function is evaluated before using the result in the next +-- application. This function is strict in the starting value. +foldlWithKey' :: (a -> k -> v -> a) -> a -> CritBit k v -> a +foldlWithKey' f z m = foldlWithKeyWith seq f z m +{-# INLINABLE foldlWithKey' #-} + +foldlWithKeyWith :: (a -> a -> a) -> (a -> k -> v -> a) -> a -> CritBit k v -> a +foldlWithKeyWith maybeSeq f z0 (CritBit root) = go z0 root + where + go z (Internal left right _ _) = let z' = go z left + in z' `maybeSeq` go z' right + go z (Leaf k v) = f z k v + go z Empty = z +{-# INLINE foldlWithKeyWith #-} + +-- | /O(n)/. Fold the values in the map using the given +-- right-associative function, such that +-- @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +-- +-- Example: +-- +-- > elems map = foldr (:) [] map +foldr :: (v -> a -> a) -> a -> CritBit k v -> a +foldr f z m = foldrWithKeyWith (\_ b -> b) (\_ v a -> f v a) z m +{-# INLINABLE foldr #-} + +-- | /O(n)/. A strict version of 'foldr'. Each application of the +-- function is evaluated before using the result in the next +-- application. This function is strict in the starting value. +foldr' :: (v -> a -> a) -> a -> CritBit k v -> a +foldr' f z m = foldrWithKeyWith seq (\_ v a -> f v a) z m +{-# INLINABLE foldr' #-} + +-- | /O(n)/. Fold the keys and values in the map using the given +-- right-associative function, such that +-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +-- +-- Examples: +-- +-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map +-- +-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldrWithKey f "Map: " (fromList [("a",5), ("b",3)]) == "Map: (a:5)(b:3)" +foldrWithKey :: (k -> v -> a -> a) -> a -> CritBit k v -> a +foldrWithKey f z m = foldrWithKeyWith (\_ b -> b) f z m +{-# INLINABLE foldrWithKey #-} + +-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of +-- the function is evaluated before using the result in the next +-- application. This function is strict in the starting value. +foldrWithKey' :: (k -> v -> a -> a) -> a -> CritBit k v -> a +foldrWithKey' f z m = foldrWithKeyWith seq f z m +{-# INLINABLE foldrWithKey' #-} + +foldrWithKeyWith :: (a -> a -> a) -> (k -> v -> a -> a) -> a -> CritBit k v -> a +foldrWithKeyWith maybeSeq f z0 (CritBit root) = go root z0 + where + go (Internal left right _ _) z = let z' = go right z + in z' `maybeSeq` go left z' + go (Leaf k v) z = f k v z + go Empty z = z +{-# INLINE foldrWithKeyWith #-} + +-- | /O(n)/. Return all keys of the map in ascending order. +-- +-- > keys (fromList [("b",5), ("a",3)]) == ["a","b"] +-- > keys empty == [] +keys :: CritBit k v -> [k] +keys m = foldrWithKey f [] m + where f k _ ks = k : ks + +unionL :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v +unionL a b = foldlWithKey' (\m k v -> insert k v m) b a +{-# INLINABLE unionL #-} + +unionR :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v +unionR a b = foldlWithKey' (\m k v -> insert k v m) a b +{-# INLINABLE unionR #-} + +union :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v +union a b = unionL a b +{-# INLINE union #-} diff --git a/Data/CritBit/Types/Internal.hs b/Data/CritBit/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/CritBit/Types/Internal.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Module : Data.CritBit.Types.Internal +-- Copyright : (c) Bryan O'Sullivan 2013 +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +module Data.CritBit.Types.Internal + ( + CritBitKey(..) + , CritBit(..) + , BitMask + , Node(..) + , toList + ) where + +import Control.DeepSeq (NFData(..)) +import Data.Bits ((.|.), (.&.), shiftL, shiftR) +import Data.ByteString (ByteString) +import Data.Text () +import Data.Text.Internal (Text(..)) +import Data.Word (Word16) +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.Text.Array as T + +type BitMask = Word16 + +data Node k v = + Internal { + ileft, iright :: !(Node k v) + , ibyte :: !Int + -- ^ The byte at which the left and right subtrees differ. + , iotherBits :: !BitMask + -- ^ The bitmask representing the critical bit within the + -- differing byte. If the critical bit is e.g. 0x8, the bitmask + -- will have every bit below 0x8 set, hence 0x7. + } + | Leaf k v + | Empty + -- ^ Logically, the 'Empty' constructor is a property of the tree, + -- rather than a node (a non-empty tree will never contain any + -- 'Empty' constructors). In practice, turning 'CritBit' from a + -- newtype into an ADT with an 'Empty' constructor adds a + -- pattern-match and a memory indirection to every function, which + -- slows them all down. + deriving (Eq, Show) + +instance (NFData k, NFData v) => NFData (Node k v) where + rnf (Internal l r _ _) = rnf l `seq` rnf r + rnf (Leaf k v) = rnf k `seq` rnf v + rnf Empty = () + +-- | A crit-bit tree. +newtype CritBit k v = CritBit { + cbRoot :: Node k v + } deriving (Eq, NFData) + +instance (Show k, Show v) => Show (CritBit k v) where + show t = "fromList " ++ show (toList t) + +-- | A type that can be used as a key in a crit-bit tree. +-- +-- We use 9 bits to represent 8-bit bytes so that we can distinguish +-- between an interior byte that is zero (which must have the 9th bit +-- set) and a byte past the end of the input (which must /not/ have +-- the 9th bit set). +-- +-- Without this trick, the critical bit calculations would fail on +-- zero bytes /within/ a string, and our tree would be unable to +-- handle arbitrary binary data. +class (Eq k) => CritBitKey k where + -- | Return the number of bytes used by this key. + -- + -- For reasonable performance, implementations must be inlined and + -- /O(1)/. + byteCount :: k -> Int + + -- | Return the byte at the given offset (counted in bytes) of + -- this key, bitwise-ORed with 256. If the offset is past the end + -- of the key, return zero. + -- + -- For reasonable performance, implementations must be inlined and + -- /O(1)/. + getByte :: k -> Int -> Word16 + +instance CritBitKey ByteString where + byteCount = B.length + {-# INLINE byteCount #-} + + getByte bs n + | n < B.length bs = fromIntegral (B.unsafeIndex bs n) .|. 256 + | otherwise = 0 + {-# INLINE getByte #-} + +instance CritBitKey Text where + byteCount (Text _ _ len) = len `shiftL` 1 + {-# INLINE byteCount #-} + + getByte (Text arr off len) n + | n < len `shiftL` 1 = + let word = T.unsafeIndex arr (off + (n `shiftR` 1)) + byteInWord = (word `shiftR` ((n .&. 1) `shiftL` 3)) .&. 0xff + in byteInWord .|. 256 + | otherwise = 0 + {-# INLINE getByte #-} + +-- | /O(n)/. Convert the map to a list of key\/value pairs. The list +-- returned will be sorted in lexicographically ascending order. +-- +-- > toList (fromList [("b",3), ("a",5)]) == [("a",5),("b",3)] +-- > toList empty == [] +toList :: CritBit k v -> [(k, v)] +toList (CritBit root) = go root [] + where + go (Internal l r _ _) next = go l (go r next) + go (Leaf k v) next = (k,v) : next + go Empty next = next diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2013 Bryan O'Sullivan +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. + +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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,208 @@ +Crit-bit trees for Haskell +==== + +This is the first purely functional implementation of crit-bit trees +that I'm aware of. + +This package exists in part with education in mind: + +* The core data structures are simple. + +* The core algorithms are easy to grasp. + +* I have intentionally structured the source to be easy to follow and + extend. + +* I've *deliberately* left the package incomplete. Ever thought to + yourself, "I'd write a bit of Haskell if only I had a project to + work on"? Well, here's your chance! I will set aside time to + review your code and answer what questions I can. + +Education aside, crit-bit trees offer some interesting features +compared to other key/value container types in Haskell. + +* For many operations, they are much faster than `Data.Map` from the + `containers` package. For instance, [`lookup` is about 3x + faster](http://htmlpreview.github.io/?https://github.com/bos/critbit/blob/master/doc/criterion-sample-lookup.html). + +* Compared to `Data.HashMap`, you get about the same lookup + performance, but also some features that a hash-based structure + can't provide: prefix-based search, efficient neighbour lookup, + ordered storage. + +Of course crit-bit trees have some downsides, too. For example, +building a tree from randomly ordered inputs is somewhat slow, and of +course the set of usable key types is small (only types that can be +interpreted as bitstrings "for free"). + +Compared to the most easily findable crit-bit tree code you'll come +across that's [written in C](https://github.com/glk/critbit), the core +of this library has a lot less accidental complexity, and so may be +easier to understand. It also handles arbitrary binary data that will +cause the C library to go wrong. + + + +How to contribute +==== + +I've purposely published this package in an incomplete state, and I'd +like your help to round it out. In return, you get to learn a little +Haskell, have your code reviewed by someone who wants to see you +succeed, and contribute to a rather nifty library. + +Do you need any prior experience with Haskell to get started? No! All +you need is curiosity and the ability to learn from context. Oh, and a +github account. + +My aim with this library is drop-in API compatibility with the widely +used Haskell [`containers`](https://github.com/haskell/containers) +library, which has two happy consequences: + +* There are lots of functions to write! + +* In almost every case, you'll find a pre-existing function in + `containers` that (from a user's perspective) does exactly what its + counterparts in *this* library ought to do. + + +Getting started +---- + +If you want to contribute or play around, please use the most modern +version of the [Haskell Platform](http://www.haskell.org/platform/). + +Once you have the Platform installed, there are just a few more steps. + +Set up your local database of known open source Haskell packages. + + cabal update + +Install the latest version of the `cabal` command, without which you +won't be able to build or run benchmarks. You'll also want a sandbox +environment. I like `cabal-dev`, and there are plenty of others. + + cabal install cabal-install + cabal install cabal-dev + +Both the new `cabal` command and `cabal-dev` will install to +`$HOME/.cabal/bin`, so put that directory at the front of your shell's +search path before you continue. + +Get the `critbit` source. + + git clone git://github.com/bos/critbit + +Set up a sandbox. + +The first time through, you need to download and install a ton of +dependencies, so hang in there. + + cd critbit + cabal-dev install \ + --enable-tests \ + --enable-benchmarks \ + --only-dependencies \ + -j + +The `cabal-dev` command is just a sandboxing wrapper around the +`cabal` command. The `-j` flag above tells `cabal` to use all of your +CPUs, so even the initial build shouldn't take more than a few +minutes. + + cabal-dev configure \ + --enable-tests \ + --enable-benchmarks + cabal-dev build + + +Running the test suite +---- + +Once you've built the code, you can run the entire test suite in a few +seconds. + + dist/build/tests/tests +RTS -N + +(The `+RTS -N` above tells GHC's runtime system to use all available +cores.) + +If you want to explore, the `tests` program accepts a `--help` +option. Try it out. + + +Running benchmarks +---- + +It is just as easy to benchmark stuff as to test it. + +First, you need a dictionary. If your system doesn't have a file named +`/usr/share/dict/words`, you can [download a dictionary +here](http://www.cs.duke.edu/~ola/ap/linuxwords). + +If you've downloaded a dictionary, tell the benchmark +suite where to find it by setting the `WORDS` environment variable. + + export WORDS=/my/path/to/linuxwords + +You can then run benchmarks and generate a report. For instance, this +runs every benchmark that begins with `bytestring/lookup`. + + dist/build/benchmarks/benchmarks -o lookup.html \ + bytestring/lookup + +Open the `lookup.html` file in your browser. [Here's an +example](http://htmlpreview.github.io/?https://github.com/bos/critbit/blob/master/doc/criterion-sample-lookup.html) +of what to expect. + +As with `tests`, run the `benchmarks` program with `--help` if you +want to do some exploring. + + + +What your code should look like +---- + +Okay, so you've bought into this idea, and would like to try writing a +patch. How to begin? + +I've generally tried to write commits with a view to being readable, +so there are examples you can follow. + +For instance, [here's the commit where I added the `keys` +function](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3). This +commit follows a simple pattern: + +* [Uncomment the export](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L0L91) of the function. + +* [Write the function + definition](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L0R503). + In this case, the documentation is taken almost verbatim from the + corresponding function in [the `Data.Map` + module](https://github.com/haskell/containers/blob/342a95002822cca56f2d5b086cdd5a98592d5c10/Data/Map/Base.hs#L1889). + +* [Write a + test](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L2R108) + and [make sure it gets + run](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L2R124). + +* [Add an entry to the benchmark + suite](https://github.com/bos/critbit/commit/48438b48ca9bc5d96c1987afe7acdf4dada823f3#L1R179) + so it's easy to see how this compares to other key/value map types. + +Naturally, you'll follow the prevailing coding and formatting style. +If you forget, I'll be sad and offer you only a terse "fix your +formatting" review, and then you'll be sad too. + + +Setting expectations +==== + +I have no idea whether this experiment will attract zero contributors +or a hundred. If the former, that's too bad, and I'll flesh the +library out at my own pace. If the latter, I'll do my best to keep up, +and we'll be more systematic if necessary (it would be a shame to see +several redundant pull requests implementing the same functions, is +what I'm thinking). + +But the main point of this is: have fun! diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Benchmarks.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables #-} +module Main (main) where + +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.DeepSeq (NFData(..)) +import Control.Exception (catch, evaluate) +import Control.Monad (when) +import Control.Monad.Trans (liftIO) +import Criterion.Main (bench, bgroup, defaultMain, nf, whnf) +import Criterion.Types (Pure) +import Data.Hashable (Hashable(..), hashByteArray) +import Data.Maybe (fromMaybe) +import Data.Text.Array (aBA) +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Internal (Text(..)) +import System.Environment (lookupEnv) +import System.IO (hPutStrLn, stderr) +import System.IO.Error (ioError, isDoesNotExistError) +import System.Random.MWC (GenIO, GenST, asGenST, create, uniform, uniformR) +import qualified Data.ByteString.Char8 as B +import qualified Data.CritBit.Map.Lazy as C +import qualified Data.HashMap.Lazy as H +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import qualified Data.Trie as Trie +import qualified Data.Vector.Generic.Mutable as M + +#if 0 +instance Hashable Text where + hash (Text arr off len) = hashByteArray (aBA arr) (off * 2) (len * 2) + {-# INLINE hash #-} +#endif + +instance (NFData a) => NFData (Trie.Trie a) where + rnf = rnf . Trie.toList + +every k = go 0 + where + go i (x:xs) + | i == k-1 = x : go 0 xs + | otherwise = go (i+1) xs + go _ _ = [] + +shuffle :: GenIO -> Double -> [Int] -> IO [Int] +shuffle gen prob xs = do + let vec = V.fromList xs + len = G.length vec + v <- G.unsafeThaw vec + let go i | i == 1 = return () + | otherwise = do + p <- uniform gen + when (p <= prob) $ + M.unsafeSwap v i =<< uniformR (0, i) gen + go (i-1) + go (len - 1) + V.toList <$> G.unsafeFreeze v + +chartres = do + let xs = [0..2999] + nxs = fromIntegral (length xs) :: Double + go pct = do + gen <- create + let prob = fromIntegral pct / 100 + ys <- shuffle gen prob xs + let mismatches = length . filter id . zipWith (/=) xs $ ys + putStrLn $ show prob ++ " " ++ show (fromIntegral mismatches / nxs) + mapM_ go [0..100] + + +main = do + fileName <- fromMaybe "/usr/share/dict/words" <$> lookupEnv "WORDS" + ordKeys <- (every 5 . B.words) <$> B.readFile fileName + `catch` \(err::IOError) -> do + when (isDoesNotExistError err) $ do + hPutStrLn stderr + ("(point the 'WORDS' environment variable at a file " ++ + "to use it for benchmark data)") + ioError err + let b_ordKVs = zip ordKeys [(0::Int)..] + b_revKVs = reverse b_ordKVs + b_randKVs <- do + gen <- create + let kvVec = V.fromList b_ordKVs + (G.toList . G.backpermute kvVec) <$> + G.replicateM (G.length kvVec) (uniformR (0, G.length kvVec - 1) gen) + let t_ordKVs = map (first decodeUtf8) b_ordKVs + t_randKVs = map (first decodeUtf8) b_randKVs + t_revKVs = map (first decodeUtf8) b_revKVs + b_critbit = C.fromList b_ordKVs + b_map = Map.fromList b_ordKVs + b_hashmap = H.fromList b_ordKVs + b_trie = Trie.fromList b_ordKVs + key = fst . head $ b_randKVs + b_critbit_1 = C.delete key b_critbit + b_map_1 = Map.delete key b_map + b_hashmap_1 = H.delete key b_hashmap + b_trie_1 = Trie.delete key b_trie + (b_randKVs_13, b_randKVs_23) = (take (l - n) b_randKVs, drop n b_randKVs) + where + l = length b_randKVs + n = l `div` 3 + b_critbit_13 = C.fromList b_randKVs_13 + b_critbit_23 = C.fromList b_randKVs_23 + b_map_13 = Map.fromList b_randKVs_13 + b_map_23 = Map.fromList b_randKVs_23 + b_hashmap_13 = H.fromList b_randKVs_13 + b_hashmap_23 = H.fromList b_randKVs_23 + b_trie_13 = Trie.fromList b_randKVs_13 + b_trie_23 = Trie.fromList b_randKVs_23 + fromList kvs = [ + bench "critbit" $ whnf C.fromList kvs + , bench "map" $ whnf Map.fromList kvs + , bench "hashmap" $ whnf H.fromList kvs + ] + keyed critbit map hashmap trie = + [ + bgroup "present" [ + bench "critbit" $ whnf (critbit key) b_critbit + , bench "map" $ whnf (map key) b_map + , bench "hashmap" $ whnf (hashmap key) b_hashmap + , bench "trie" $ whnf (trie key) b_trie + ] + , bgroup "missing" [ + bench "critbit" $ whnf (critbit key) b_critbit_1 + , bench "map" $ whnf (map key) b_map_1 + , bench "hashmap" $ whnf (hashmap key) b_hashmap_1 + , bench "trie" $ whnf (trie key) b_trie_1 + ] + ] + twoMaps critbit map hashmap trie = [ + bench "critbit" $ whnf (critbit b_critbit_13) b_critbit_23 + , bench "map" $ whnf (map b_map_13) b_map_23 + , bench "hashmap" $ whnf (hashmap b_hashmap_13) b_hashmap_23 + , bench "trie" $ whnf (trie b_trie_13) b_trie_23 + ] + function (eval :: forall a b. NFData b => (a -> b) -> a -> Pure) + critbit map hashmap trie = [ + bench "critbit" $ eval critbit b_critbit + , bench "map" $ eval map b_map + , bench "hashmap" $ eval hashmap b_hashmap + , bench "trie" $ eval trie b_trie + ] + evaluate $ rnf [rnf b_critbit, rnf b_critbit_1, rnf b_map, rnf b_map_1, + rnf b_hashmap, rnf b_hashmap_1, rnf b_trie, rnf b_trie_1, + rnf b_randKVs, rnf b_revKVs, rnf key, + rnf b_critbit_13, rnf b_critbit_23, + rnf b_map_13, rnf b_map_23, + rnf b_hashmap_13, rnf b_hashmap_23, + rnf b_trie_13, rnf b_trie_23] + defaultMain + [ bgroup "bytestring" [ + bgroup "fromList" [ + bgroup "ordered" $ fromList b_ordKVs ++ + [ bench "trie" $ whnf Trie.fromList b_ordKVs ] + , bgroup "random" $ fromList b_randKVs ++ + [ bench "trie" $ whnf Trie.fromList b_randKVs ] + , bgroup "reversed" $ fromList b_revKVs ++ + [ bench "trie" $ whnf Trie.fromList b_revKVs ] + ] + , bgroup "delete" $ keyed C.delete Map.delete H.delete Trie.delete + , bgroup "insert" $ keyed (flip C.insert 1) (flip Map.insert 1) + (flip H.insert 1) (flip Trie.insert 1) + , bgroup "lookup" $ keyed C.lookup Map.lookup H.lookup Trie.lookup + , bgroup "lookupGT" $ [ + bench "critbit" $ whnf (C.lookupGT key) b_critbit + , bench "map" $ whnf (Map.lookupGT key) b_map + ] + , bgroup "member" $ keyed C.member Map.member H.member Trie.member + , bgroup "foldlWithKey'" $ let f a _ b = a + b + in function whnf (C.foldlWithKey' f 0) + (Map.foldlWithKey' f 0) + (H.foldlWithKey' f 0) id + , bgroup "foldl'" $ function whnf (C.foldl' (+) 0) (Map.foldl' (+) 0) + (H.foldl' (+) 0) id + , bgroup "keys" $ function nf C.keys Map.keys H.keys Trie.keys + , bgroup "union" $ twoMaps C.unionR Map.union H.union Trie.unionR + ] + , bgroup "text" [ + bgroup "fromList" [ + bgroup "ordered" $ fromList t_ordKVs + , bgroup "random" $ fromList t_randKVs + , bgroup "reversed" $ fromList t_revKVs + ] + ] + ] diff --git a/critbit.cabal b/critbit.cabal new file mode 100644 --- /dev/null +++ b/critbit.cabal @@ -0,0 +1,91 @@ +name: critbit +version: 0.0.0.0 +homepage: https://github.com/bos/critbit +bug-reports: https://github.com/bos/critbit/issues +synopsis: Crit-bit maps and sets +description: + Whee. +license: BSD3 +license-file: LICENSE +author: Bryan O'Sullivan +maintainer: Bryan O'Sullivan +copyright: 2013 Bryan O'Sullivan +category: Data +build-type: Simple +cabal-version: >= 1.8 +extra-source-files: + README.markdown + +flag developer + description: operate in developer mode + default: False + +library + exposed-modules: + Data.CritBit.Map.Lazy + other-modules: + Data.CritBit.Core + Data.CritBit.Types.Internal + Data.CritBit.Tree + + build-depends: + base >= 4 && < 5, + bytestring >= 0.9, + deepseq, + text >= 0.11.3.1, + vector + + ghc-options: -Wall -funbox-strict-fields -O2 -fwarn-tabs + if flag(developer) + ghc-prof-options: -auto-all + ghc-options: -Werror + cpp-options: -DASSERTS + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + if impl(ghc >= 7.4) + other-modules: Properties + + ghc-options: + -Wall -threaded -rtsopts + + build-depends: + base >= 4 && < 5, + bytestring, + containers, + critbit, + QuickCheck >= 2.4, + test-framework >= 0.4, + test-framework-quickcheck2 >= 0.2, + text + +benchmark benchmarks + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Benchmarks.hs + ghc-options: -O2 -rtsopts + + build-depends: + base >= 4 && < 5, + bytestring, + bytestring-trie, + containers, + critbit, + criterion >= 0.8, + deepseq, + hashable < 1.2, + mtl, + mwc-random, + text, + unordered-containers, + vector + +source-repository head + type: git + location: https://github.com/bos/critbit + +source-repository head + type: mercurial + location: https://bitbucket.org/bos/critbit diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +module Main (main) where + +import Test.Framework + +#if MIN_VERSION_base(4,5,0) +import Properties (properties) +#else +import Test.Framework.Providers.QuickCheck2 (testProperty) + +-- Don't run any tests on GHC < 7.4, but *do* generate a test output +-- file that a continuous build system can consume so that it won't +-- crash. The output file can't be devoid of tests, because then +-- instead of crashing Jenkins will fail because no tests were run. +-- Thanks for being so inflexible, Jenkins! +properties = [ testProperty "fuck you, jenkins" True ] +#endif + +main :: IO () +main = defaultMain [ + testGroup "properties" properties + ] diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Properties + where + +import Control.Applicative ((<$>)) +import Data.ByteString (ByteString) +import Data.CritBit.Map.Lazy (CritBitKey, CritBit) +import Data.Text (Text) +import Data.Word (Word8) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Arbitrary(..), Args(..), quickCheckWith, stdArgs) +import Test.QuickCheck.Property (Testable) +import qualified Data.ByteString as BB +import qualified Data.ByteString.Char8 as B +import qualified Data.CritBit.Map.Lazy as C +import qualified Data.Map as Map +import qualified Data.Text as T + +instance Arbitrary ByteString where + arbitrary = BB.pack <$> arbitrary + shrink = map B.pack . shrink . B.unpack + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + shrink = map T.pack . shrink . T.unpack + +type V = Word8 + +newtype KV a = KV { fromKV :: [(a, V)] } + deriving (Show, Eq, Ord) + +instance Arbitrary a => Arbitrary (KV a) where + arbitrary = (KV . flip zip [0..]) <$> arbitrary + shrink = map (KV . flip zip [0..]) . shrink . map fst . fromKV + +instance (CritBitKey k, Arbitrary k, Arbitrary v) => + Arbitrary (CritBit k v) where + arbitrary = C.fromList <$> arbitrary + shrink = map C.fromList . shrink . C.toList + +newtype CB k = CB (CritBit k V) + deriving (Show, Eq, Arbitrary) + +t_lookup_present :: (CritBitKey k) => k -> k -> V -> CB k -> Bool +t_lookup_present _ k v (CB m) = C.lookup k (C.insert k v m) == Just v + +t_lookup_missing :: (CritBitKey k) => k -> k -> CB k -> Bool +t_lookup_missing _ k (CB m) = C.lookup k (C.delete k m) == Nothing + +#if MIN_VERSION_containers(0,5,0) +t_lookupGT :: (Ord k, CritBitKey k) => k -> k -> KV k -> Bool +t_lookupGT _ k (KV kvs) = + C.lookupGT k (C.fromList kvs) == Map.lookupGT k (Map.fromList kvs) +#endif + +t_fromList_toList :: (CritBitKey k, Ord k) => k -> KV k -> Bool +t_fromList_toList _ (KV kvs) = + Map.toList (Map.fromList kvs) == C.toList (C.fromList kvs) + +t_fromList_size :: (CritBitKey k, Ord k) => k -> KV k -> Bool +t_fromList_size _ (KV kvs) = + Map.size (Map.fromList kvs) == C.size (C.fromList kvs) + +t_delete_present :: (CritBitKey k, Ord k) => k -> KV k -> k -> V -> Bool +t_delete_present _ (KV kvs) k v = + C.toList (C.delete k c) == Map.toList (Map.delete k m) + where + c = C.insert k v $ C.fromList kvs + m = Map.insert k v $ Map.fromList kvs + +t_unionL :: (CritBitKey k, Ord k) => k -> KV k -> KV k -> Bool +t_unionL _ (KV kv0) (KV kv1) = + Map.toList (Map.fromList kv0 `Map.union` Map.fromList kv1) == + C.toList (C.fromList kv0 `C.unionL` C.fromList kv1) + +t_foldl :: (CritBitKey k) => k -> CritBit k V -> Bool +t_foldl _ m = C.foldl (+) 0 m == C.foldr (+) 0 m + +t_foldlWithKey :: (CritBitKey k, Ord k) => k -> KV k -> Bool +t_foldlWithKey _ (KV kvs) = + C.foldlWithKey f ([], 0) (C.fromList kvs) == + Map.foldlWithKey f ([], 0) (Map.fromList kvs) + where + f (l,s) k v = (k:l,s+v) + +t_foldl' :: (CritBitKey k) => k -> CritBit k V -> Bool +t_foldl' _ m = C.foldl' (+) 0 m == C.foldl (+) 0 m + +t_foldlWithKey' :: (CritBitKey k, Ord k) => k -> KV k -> Bool +t_foldlWithKey' _ (KV kvs) = + C.foldlWithKey' f ([], 0) (C.fromList kvs) == + Map.foldlWithKey' f ([], 0) (Map.fromList kvs) + where + f (l,s) k v = (k:l,s+v) + +t_keys :: (CritBitKey k, Ord k) => k -> KV k -> Bool +t_keys _ (KV kvs) = C.keys (C.fromList kvs) == Map.keys (Map.fromList kvs) + +propertiesFor :: (Arbitrary k, CritBitKey k, Ord k, Show k) => k -> [Test] +propertiesFor t = [ + testProperty "t_fromList_toList" $ t_fromList_toList t + , testProperty "t_fromList_size" $ t_fromList_size t + , testProperty "t_lookup_present" $ t_lookup_present t + , testProperty "t_lookup_missing" $ t_lookup_missing t +#if MIN_VERSION_containers(0,5,0) + , testProperty "t_lookupGT" $ t_lookupGT t +#endif + , testProperty "t_delete_present" $ t_delete_present t + , testProperty "t_unionL" $ t_unionL t + , testProperty "t_foldl" $ t_foldl t + , testProperty "t_foldlWithKey" $ t_foldlWithKey t + , testProperty "t_foldl'" $ t_foldl' t + , testProperty "t_foldlWithKey'" $ t_foldlWithKey' t + , testProperty "t_keys" $ t_keys t + ] + +properties :: [Test] +properties = [ + testGroup "text" $ propertiesFor T.empty + , testGroup "bytestring" $ propertiesFor B.empty + ] + +-- Handy functions for fiddling with from ghci. + +blist :: [ByteString] -> CritBit ByteString Word8 +blist = C.fromList . flip zip [0..] + +tlist :: [Text] -> CritBit Text Word8 +tlist = C.fromList . flip zip [0..] + +mlist :: [ByteString] -> Map.Map ByteString Word8 +mlist = Map.fromList . flip zip [0..] + +qc :: Testable prop => Int -> prop -> IO () +qc n = quickCheckWith stdArgs { maxSuccess = n }