diff --git a/Data/CritBit/Core.hs b/Data/CritBit/Core.hs
--- a/Data/CritBit/Core.hs
+++ b/Data/CritBit/Core.hs
@@ -1,5 +1,6 @@
+{-# LANGUAGE BangPatterns, RecordWildCards, ScopedTypeVariables #-}
-- |
--- Module : Data.CritBit.Tree
+-- Module : Data.CritBit.Core
-- Copyright : (c) Bryan O'Sullivan 2013
-- License : BSD-style
-- Maintainer : bos@serpentine.com
@@ -17,54 +18,150 @@
module Data.CritBit.Core
(
-- * Public functions
- insert
+ insertWithKey
+ , insertLookupWithKey
+ , insertLookupGen
, lookupWith
- , delete
+ , updateLookupWithKey
+ , leftmost
+ , rightmost
-- * Internal functions
- , calcDirection
- , direction
+ , Diff(..)
+ , diffOrd
, followPrefixes
+ , followPrefixesFrom
+ , followPrefixesByteFrom
+ , findPosition
+ -- ** Predicates
+ , onLeft
+ , above
+ -- ** Smart constructors
+ , setLeft
+ , setRight
+ , setLeft'
+ , setRight'
+ , internal
) 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'@.
+-- | /O(k)/. Insert with a function, combining key, new value and old value.
+-- @'insertWithKey' f key value cb@
+-- will insert the pair (key, value) into cb if key does not exist in the map.
+-- If the key does exist, the function will insert the pair
+-- @(key,f key new_value old_value)@.
+-- Note that the key passed to f is the same key passed to insertWithKey.
--
--- > 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
+-- > let f key new_value old_value = byteCount key + new_value + old_value
+-- > insertWithKey f "a" 1 (fromList [("a",5), ("b",3)]) == fromList [("a",7), ("b",3)]
+-- > insertWithKey f "c" 1 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("c",1)]
+-- > insertWithKey f "a" 1 empty == singleton "a" 1
+insertWithKey :: CritBitKey k => (k -> v -> v -> v) -> k -> v -> CritBit k v
+ -> CritBit k v
+insertWithKey f k v m = insertLookupGen (flip const) f k v m
+{-# INLINABLE insertWithKey #-}
+
+-- | /O(k)/. Combines insert operation with old value retrieval.
+-- The expression (@'insertLookupWithKey' f k x map@)
+-- is a pair where the first element is equal to (@'lookup' k map@)
+-- and the second element equal to (@'insertWithKey' f k x map@).
+--
+-- > let f key new_value old_value = length key + old_value + new_value
+-- > insertLookupWithKey f "a" 2 (fromList [("a",5), ("b",3)]) == (Just 5, fromList [("a",8), ("b",3)])
+-- > insertLookupWithKey f "c" 2 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [("a",5), ("b",3), ("c",2)])
+-- > insertLookupWithKey f "a" 2 empty == (Nothing, singleton "a" 2)
+--
+-- This is how to define @insertLookup@ using @insertLookupWithKey@:
+--
+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
+-- > insertLookup "a" 1 (fromList [("a",5), ("b",3)]) == (Just 5, fromList [("a",1), ("b",3)])
+-- > insertLookup "c" 1 (fromList [("a",5), ("b",3)]) == (Nothing, fromList [("a",5), ("b",3), ("c",1)])
+insertLookupWithKey :: CritBitKey k
+ => (k -> v -> v -> v)
+ -> k -> v -> CritBit k v
+ -> (Maybe v, CritBit k v)
+insertLookupWithKey f k v m = insertLookupGen (,) f k v m
+{-# INLINABLE insertLookupWithKey #-}
+
+-- | General function used to implement all insert functions.
+insertLookupGen :: CritBitKey k
+ => (Maybe v -> CritBit k v -> a)
+ -> (k -> v -> v -> v)
+ -> k -> v -> CritBit k v -> a
+insertLookupGen ret f !k v m = findPosition ret' finish setLeft setRight k m
where
- go i@(Internal left right _ _)
- | direction k i == 0 = go left
- | otherwise = go right
- go (Leaf lk _) = rewalk root
+ finish _ Empty = Leaf k v
+ finish diff (Leaf _ v') | diffOrd diff == EQ = Leaf k $ f k v v'
+ finish diff node = internal diff node (Leaf k v)
+
+ ret' a b = ret a (CritBit b)
+{-# INLINE insertLookupGen #-}
+
+-- | Common part of key finding/insert functions
+findPosition :: (CritBitKey k)
+ => (Maybe v -> r -> t) -> (Diff -> Node k v -> r)
+ -> (Node k v -> r -> r) -> (Node k v -> r -> r)
+ -> k -> CritBit k v -> t
+findPosition ret finish toLeft toRight k (CritBit root) = go root
+ where
+ go i@(Internal {..})
+ | k `onLeft` i = go ileft
+ | otherwise = go iright
+ go (Leaf lk lv)
+ | diffOrd diff == EQ = ret (Just lv) $ rewalk root
+ | otherwise = ret Nothing $ 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
+ rewalk i@(Internal left right _ _)
+ | diff `above` i = finish diff i
+ | k `onLeft` i = toLeft i (rewalk left )
+ | otherwise = toRight i (rewalk right)
+ rewalk i = finish diff 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 }
+ diff = followPrefixes k lk
+ go Empty = ret Nothing $ finish undefined Empty
+{-# INLINE findPosition #-}
- (n, nob, c) = followPrefixes k lk
- nd = calcDirection nob c
- go Empty = Leaf k v
-{-# INLINABLE insert #-}
+data Diff = Diff {-# UNPACK #-} !Int
+ {-# UNPACK #-} !BitMask
+ {-# UNPACK #-} !BitMask
+-- | Smart consturctor for Internal nodes
+internal :: Diff -> Node k v -> Node k v -> Node k v
+internal diff@(Diff byte bits _) child1 child2 = case diffOrd diff of
+ LT -> Internal child1 child2 byte bits
+ GT -> Internal child2 child1 byte bits
+ EQ -> error "Data.CritBit.Cord.internal: Equal."
+{-# INLINE internal #-}
+
+setLeft :: Node k v -> Node k v -> Node k v
+setLeft i@(Internal{}) node = i { ileft = node }
+setLeft _ _ = error "Data.CritBit.Core.setLeft: Non-Internal node"
+{-# INLINE setLeft #-}
+
+setRight :: Node k v -> Node k v -> Node k v
+setRight i@(Internal{}) node = i { iright = node }
+setRight _ _ = error "Data.CritBit.Core.setRight: Non-Internal node"
+{-# INLINE setRight #-}
+
+setLeft' :: Node k v -> Node k v -> Node k v
+setLeft' i@(Internal{}) Empty = iright i
+setLeft' i@(Internal{}) child = i { ileft = child }
+setLeft' _ _ = error "Data.CritBit.Core.setLeft': Non-internal node"
+{-# INLINE setLeft' #-}
+
+setRight' :: Node k v -> Node k v -> Node k v
+setRight' i@(Internal{}) Empty = ileft i
+setRight' i@(Internal{}) child = i { iright = child }
+setRight' _ _ = error "Data.CritBit.Core.alter.setRight': Non-internal node"
+{-# INLINE setRight' #-}
+
+above :: Diff -> Node k v -> Bool
+above (Diff dbyte dbits _) (Internal _ _ byte bits) =
+ dbyte < byte || dbyte == byte && dbits < bits
+above _ _ = error "Data.CritBit.Core.above: Non-Internal node"
+{-# INLINE above #-}
+
lookupWith :: (CritBitKey k) =>
a -- ^ Failure continuation
-> (v -> a) -- ^ Success continuation
@@ -74,57 +171,61 @@
-- 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 i@(Internal {..})
+ | k `onLeft` i = go ileft
+ | otherwise = go iright
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.
+-- | /O(k)/. Lookup and update; see also 'updateWithKey'.
+-- This function returns the changed value if it is updated, or
+-- the original value if the entry is deleted.
--
--- > 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
+-- > let f k x = if x == 5 then Just (x + fromEnum (k < "d")) else Nothing
+-- > updateLookupWithKey f "a" (fromList [("b",3), ("a",5)]) == (Just 6, fromList [("a", 6), ("b",3)])
+-- > updateLookupWithKey f "c" (fromList [("a",5), ("b",3)]) == (Nothing, fromList [("a",5), ("b",3)])
+-- > updateLookupWithKey f "b" (fromList [("a",5), ("b",3)]) == (Just 3, singleton "a" 5)
+updateLookupWithKey :: (CritBitKey k) => (k -> v -> Maybe v) -> k
+ -> CritBit k v -> (Maybe 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
+updateLookupWithKey f k t@(CritBit root) = go root (CritBit Empty) 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 #-}
+ go i@(Internal left right _ _) _ cont = dispatch i left right cont
+ go (Leaf lk lv) other cont
+ | k == lk = case f lk lv of
+ Just lv' -> (Just lv', cont $! Leaf lk lv')
+ Nothing -> (Just lv, other)
+ | otherwise = (Nothing, t)
+ go Empty _ _ = (Nothing, t)
+ {-# INLINE go #-}
--- | 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 #-}
+ dispatch i left right cont
+ | k `onLeft` i = go left (cont right) $ (cont $!) . setLeft' i
+ | otherwise = go right (cont left) $ (cont $!) . setRight' i
+{-# INLINABLE updateLookupWithKey #-}
--- 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 #-}
+-- | Determine whether specified key is on the left subtree of the
+-- 'Internal' node.
+onLeft :: (CritBitKey k) => k -> Node k v -> Bool
+onLeft k (Internal _ _ byte bits) =
+ (1 + (bits .|. getByte k byte)) `shiftR` 9 == 0
+onLeft _ _ = error "Data.CritBit.Core.onLeft: Non-Internal node"
+{-# INLINE onLeft #-}
+-- | Given a diff of two keys determines result of comparison of them.
+diffOrd :: Diff -> Ordering
+diffOrd (Diff _ bits c)
+ | bits == 0x1ff = EQ
+ | (1 + (bits .|. c)) `shiftR` 9 == 0 = LT
+ | otherwise = GT
+{-# INLINE diffOrd #-}
+
-- | 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.
--
@@ -133,20 +234,65 @@
followPrefixes :: (CritBitKey k) =>
k -- ^ The key from "outside" the tree.
-> k -- ^ Key from the leaf we reached.
- -> (Int, BitMask, Word16)
+ -> Diff
+followPrefixes = followPrefixesFrom 0
{-# INLINE followPrefixes #-}
-followPrefixes k l = go 0
+
+-- | Figure out the offset of the first different byte in two keys,
+-- starting from specified position.
+--
+-- 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.
+followPrefixesFrom :: (CritBitKey k) =>
+ Int -- ^ Positition to start from
+ -> k -- ^ First key.
+ -> k -- ^ Second key.
+ -> Diff
+followPrefixesFrom !position !k !l = Diff n (maskLowerBits (b `xor` c)) c
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
+ n = followPrefixesByteFrom position k l
+ b = getByte k n
+ c = getByte l n
- maskLowerBits v = (n3 .&. (complement (n3 `shiftR` 1))) `xor` 511
+ maskLowerBits v = (n3 .&. complement (n3 `shiftR` 1)) `xor` 0x1FF
where
n3 = n2 .|. (n2 `shiftR` 8)
n2 = n1 .|. (n1 `shiftR` 4)
n1 = n0 .|. (n0 `shiftR` 2)
n0 = v .|. (v `shiftR` 1)
+{-# INLINE followPrefixesFrom #-}
+
+-- | Figure out the offset of the first different byte in two keys,
+-- starting from specified position.
+followPrefixesByteFrom :: (CritBitKey k) =>
+ Int -- ^ Positition to start from
+ -> k -- ^ First key.
+ -> k -- ^ Second key.
+ -> Int
+followPrefixesByteFrom !position !k !l = go position
+ where
+ go !n | b /= c || b == 0 || c == 0 = n
+ | otherwise = go (n + 1)
+ where b = getByte k n
+ c = getByte l n
+{-# INLINE followPrefixesByteFrom #-}
+
+leftmost, rightmost :: a -> (k -> v -> a) -> Node k v -> a
+leftmost = extremity ileft
+{-# INLINE leftmost #-}
+rightmost = extremity iright
+{-# INLINE rightmost #-}
+
+-- | Generic function so we can easily implement 'leftmost' and 'rightmost'.
+extremity :: (Node k v -> Node k v) -- ^ Either 'ileft' or 'iright'.
+ -> a -- ^ 'Empty' continuation.
+ -> (k -> v -> a) -- ^ 'Leaf' continuation.
+ -> Node k v
+ -> a
+extremity direct onEmpty onLeaf node = go node
+ where
+ go i@(Internal{}) = go $ direct i
+ go (Leaf k v) = onLeaf k v
+ go _ = onEmpty
+ {-# INLINE go #-}
+{-# INLINE extremity #-}
diff --git a/Data/CritBit/Set.hs b/Data/CritBit/Set.hs
new file mode 100644
--- /dev/null
+++ b/Data/CritBit/Set.hs
@@ -0,0 +1,456 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- |
+-- Module : Data.CritBit.Set
+-- Copyright : (c) Bryan O'Sullivan and others 2013-2014
+-- License : BSD-style
+-- Maintainer : bos@serpentine.com
+-- Stability : experimental
+-- Portability : GHC
+--
+-- A set type that uses crit-bit trees internally.
+--
+-- 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.Set
+ (
+ -- * Set type
+ Set
+
+ -- * Operators
+ , (\\)
+
+ -- * Query
+ , null
+ , size
+ , member
+ , notMember
+ , lookupLT
+ , lookupGT
+ , lookupLE
+ , lookupGE
+ , isSubsetOf
+ , isProperSubsetOf
+
+ -- * Construction
+ , empty
+ , singleton
+ , insert
+ , delete
+
+ -- * Combine
+ , union
+ , unions
+ , difference
+ , intersection
+
+ -- * Filter
+ , filter
+ , partition
+ , split
+ , splitMember
+
+ -- * Map
+ , map
+ , mapMonotonic
+
+ -- * Folds
+ , foldr
+ , foldl
+ -- ** Strict folds
+ , foldr'
+ , foldl'
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , maxView
+ , minView
+
+ -- * Conversion
+
+ -- ** List
+ , elems
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , toDescList
+ , fromAscList
+ , fromDistinctAscList
+ ) where
+
+import Control.Arrow ((***))
+import Data.CritBit.Types.Internal (CritBit(..), Set(..), CritBitKey, Node(..))
+import Data.Foldable (Foldable, foldMap)
+import Data.Maybe (isJust)
+import Data.Monoid (Monoid(..))
+import Prelude hiding (null, filter, map, foldl, foldr)
+import qualified Data.CritBit.Tree as T
+import qualified Data.List as List
+
+instance (Show a) => Show (Set a) where
+ show s = "fromList " ++ show (toList s)
+
+instance CritBitKey k => Monoid (Set k) where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+instance Foldable Set where
+ foldMap f (Set (CritBit n)) = foldSet f n
+
+foldSet :: (Monoid m) => (a -> m) -> Node a () -> m
+foldSet f (Internal l r _ _) = mappend (foldSet f l) (foldSet f r)
+foldSet f (Leaf k _) = f k
+foldSet _ Empty = mempty
+{-# INLINABLE foldSet #-}
+
+-- | Same as 'difference'.
+(\\) :: CritBitKey a => Set a -> Set a -> Set a
+s \\ p = difference s p
+{-# INLINABLE (\\) #-}
+
+-- | /O(1)/. Is the set empty?
+--
+-- > null (empty) == True
+-- > null (singleton "a") == False
+null :: Set a -> Bool
+null (Set a) = T.null a
+
+-- | /O(1)/. The empty set.
+--
+-- > empty == fromList []
+-- > size empty == 0
+empty :: Set a
+empty = Set T.empty
+{-# INLINABLE empty #-}
+
+-- | /O(1)/. A set with a single element.
+--
+-- > singleton "a" == fromList ["a"]
+singleton :: a -> Set a
+singleton a = Set $ T.singleton a ()
+{-# INLINE singleton #-}
+
+-- | /O(k)/. Build a set from a list of values.
+--
+-- > fromList [] == empty
+-- > fromList ["a", "b", "a"] == fromList ["a", "b"]
+fromList :: (CritBitKey a) => [a] -> Set a
+fromList = liftFromList T.fromList
+{-# INLINABLE fromList #-}
+
+-- | /O(n)/. An alias of 'toList'.
+--
+-- Returns the elements of a set in ascending order.
+elems :: Set a -> [a]
+elems = toList
+
+-- | /O(n)/. Convert the set to a list of values. The list returned
+-- will be sorted in lexicographically ascending order.
+--
+-- > toList (fromList ["b", "a"]) == ["a", "b"]
+-- > toList empty == []
+toList :: Set a -> [a]
+toList = wrapS id T.keys
+{-# INLINABLE toList #-}
+
+-- | /O(n)/. The number of elements in the set.
+--
+-- > size empty == 0
+-- > size (singleton "a") == 1
+-- > size (fromList ["a", "c", "b"]) == 3
+size :: Set a -> Int
+size = wrapS id T.size
+{-# INLINABLE size #-}
+
+-- | /O(k)/. Is the element in the set?
+--
+-- > member "a" (fromList ["a", "b"]) == True
+-- > member "c" (fromList ["a", "b"]) == False
+--
+-- See also 'notMember'.
+member :: (CritBitKey a) => a -> Set a -> Bool
+member a (Set s) = T.member a s
+{-# INLINABLE member #-}
+
+-- | /O(k)/. Is the element not in the set?
+--
+-- > notMember "a" (fromList ["a", "b"]) == False
+-- > notMember "c" (fromList ["a", "b"]) == True
+--
+-- See also 'member'.
+notMember :: (CritBitKey a) => a -> Set a -> Bool
+notMember a (Set s) = T.notMember a s
+{-# INLINABLE notMember #-}
+
+-- | /O(k)/. Find largest element smaller than the given one.
+--
+-- > lookupLT "b" (fromList ["a", "b"]) == Just "a"
+-- > lookupLT "aa" (fromList ["a", "b"]) == Just "a"
+-- > lookupLT "a" (fromList ["a", "b"]) == Nothing
+lookupLT :: (CritBitKey a) => a -> Set a -> Maybe a
+lookupLT = wrapVS (fmap fst) T.lookupLT
+{-# INLINABLE lookupLT #-}
+
+-- | /O(k)/. Find smallest element greater than the given one.
+--
+-- > lookupGT "b" (fromList ["a", "b"]) == Nothing
+-- > lookupGT "aa" (fromList ["a", "b"]) == Just "b"
+-- > lookupGT "a" (fromList ["a", "b"]) == Just "b"
+lookupGT :: (CritBitKey a) => a -> Set a -> Maybe a
+lookupGT = wrapVS (fmap fst) T.lookupGT
+{-# INLINABLE lookupGT #-}
+
+-- | /O(k)/. Find largest element smaller than or equal to the given one.
+--
+-- > lookupGE "b" (fromList ["a", "b"]) == Just "b"
+-- > lookupGE "aa" (fromList ["a", "b"]) == Just "b"
+-- > lookupGE "a" (fromList ["a", "b"]) == Just "a"
+-- > lookupGE "" (fromList ["a", "b"]) == Nothing
+lookupLE :: (CritBitKey a) => a -> Set a -> Maybe a
+lookupLE = wrapVS (fmap fst) T.lookupLE
+{-# INLINABLE lookupLE #-}
+
+-- | /O(k)/. Find smallest element greater than or equal to the given one.
+--
+-- > lookupGE "aa" (fromList ["a", "b"]) == Just "b"
+-- > lookupGE "b" (fromList ["a", "b"]) == Just "b"
+-- > lookupGE "bb" (fromList ["a", "b"]) == Nothing
+lookupGE :: (CritBitKey a) => a -> Set a -> Maybe a
+lookupGE = wrapVS (fmap fst) T.lookupGE
+{-# INLINABLE lookupGE #-}
+
+-- | /O(n+m)/. Is this a subset?
+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
+isSubsetOf :: (CritBitKey a) => Set a -> Set a -> Bool
+isSubsetOf = wrapSS id T.isSubmapOf
+{-# INLINABLE isSubsetOf #-}
+
+-- | /O(n+m)/. Is this a proper subset (ie. a subset but not equal)?
+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a proper subset of @s2@.
+isProperSubsetOf :: (CritBitKey a) => Set a -> Set a -> Bool
+isProperSubsetOf = wrapSS id T.isProperSubmapOf
+{-# INLINABLE isProperSubsetOf #-}
+
+-- | /O(k)/. Insert an element in a set.
+-- If the set already contains an element equal to the given value,
+-- it is replaced with the new value.
+insert :: (CritBitKey a) => a -> Set a -> Set a
+insert = wrapVS Set (`T.insert` ())
+{-# INLINABLE insert #-}
+
+-- | /O(k)/. Delete an element from a set.
+delete :: (CritBitKey a) => a -> Set a -> Set a
+delete = wrapVS Set T.delete
+{-# INLINABLE delete #-}
+
+-- | /O(k)/. The union of two sets, preferring the first set when
+-- equal elements are encountered.
+union :: (CritBitKey a) => Set a -> Set a -> Set a
+union = wrapSS Set T.union
+{-# INLINABLE union #-}
+
+-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
+unions :: (CritBitKey a) => [Set a] -> Set a
+unions = List.foldl' union empty
+{-# INLINABLE unions #-}
+
+-- | /O(k)/. The difference of two sets.
+difference :: (CritBitKey a) => Set a -> Set a -> Set a
+difference = wrapSS Set T.difference
+{-# INLINABLE difference #-}
+
+-- | /O(k)/. The intersection of two sets. Elements of the
+-- result come from the first set.
+intersection :: (CritBitKey a) => Set a -> Set a -> Set a
+intersection = wrapSS Set T.intersection
+{-# INLINABLE intersection #-}
+
+-- | /O(n)/. Filter all elements that satisfy the predicate.
+--
+-- > filter (> "a") (fromList ["a", "b"]) == fromList [("3","b")]
+-- > filter (> "x") (fromList ["a", "b"]) == empty
+-- > filter (< "a") (fromList ["a", "b"]) == empty
+filter :: (a -> Bool) -> Set a -> Set a
+filter = wrapVS Set (T.filterWithKey . (const .))
+{-# INLINABLE filter #-}
+
+-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
+-- the predicate and one with all elements that don't satisfy the predicate.
+-- See also 'split'.
+partition :: (CritBitKey a) => (a -> Bool) -> Set a -> (Set a, Set a)
+partition = wrapVS (Set *** Set) (T.partitionWithKey . (const .))
+{-# INLINABLE partition #-}
+
+-- | /O(k)/. The expression (@'split' x set@) is a pair @(set1,set2)@
+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
+-- comprises the elements of @set@ greater than @x@.
+--
+-- > split "a" (fromList ["b", "d"]) == (empty, fromList ["b", "d")])
+-- > split "b" (fromList ["b", "d"]) == (empty, singleton "d")
+-- > split "c" (fromList ["b", "d"]) == (singleton "b", singleton "d")
+-- > split "d" (fromList ["b", "d"]) == (singleton "b", empty)
+-- > split "e" (fromList ["b", "d"]) == (fromList ["b", "d"], empty)
+split :: (CritBitKey a) => a -> Set a -> (Set a, Set a)
+split = wrapVS (Set *** Set) T.split
+{-# INLINABLE split #-}
+
+-- | /O(k)/. Performs a 'split' but also returns whether the pivot
+-- element was found in the original set.
+--
+-- > splitMember "a" (fromList ["b", "d"]) == (empty, False, fromList ["b", "d"])
+-- > splitMember "b" (fromList ["b", "d"]) == (empty, True, singleton "d")
+-- > splitMember "c" (fromList ["b", "d"]) == (singleton "b", False, singleton "d")
+-- > splitMember "d" (fromList ["b", "d"]) == (singleton "b", True, empty)
+-- > splitMember "e" (fromList ["b", "d"]) == (fromList ["b", "d"], False, empty)
+splitMember :: (CritBitKey a) => a -> Set a -> (Set a, Bool, Set a)
+splitMember = wrapVS pack T.splitLookup
+ where pack (l, m, r) = (Set l, isJust m, Set r)
+{-# INLINABLE splitMember #-}
+
+-- | /O(k)/. @'map' f s@ is the set obtained by applying @f@ to each
+-- element of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+map :: (CritBitKey a2) => (a1 -> a2) -> Set a1 -> Set a2
+map = wrapVS Set T.mapKeys
+{-# INLINABLE map #-}
+
+-- | /O(n)/. The @'mapMonotonic' f s == 'map' f s@, but works only when
+-- @f@ is monotonic.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapMonotonic f s == map f s
+-- > where ls = toList s
+mapMonotonic :: (CritBitKey a2) => (a1 -> a2) -> Set a1 -> Set a2
+mapMonotonic = wrapVS Set T.mapKeysMonotonic
+{-# INLINABLE mapMonotonic #-}
+
+-- | /O(n)/. Fold the elements in the set using the given left-associative
+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.
+--
+-- For example,
+--
+-- > toDescList set = foldl (flip (:)) [] set
+foldl :: (a -> b -> a) -> a -> Set b -> a
+foldl f = wrapVS id (T.foldlWithKey ((const .) . f))
+{-# INLINE foldl #-}
+
+-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldl' :: (a -> b -> a) -> a -> Set b -> a
+foldl' f = wrapVS id (T.foldlWithKey' ((const .) . f))
+{-# INLINE foldl' #-}
+
+-- | /O(n)/. Fold the elements in the set using the given right-associative
+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.
+--
+-- For example,
+--
+-- > toAscList set = foldr (:) [] set
+foldr :: (a -> b -> b) -> b -> Set a -> b
+foldr f = wrapVS id (T.foldrWithKey (const . f))
+{-# INLINE foldr #-}
+
+-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
+-- evaluated before using the result in the next application. This
+-- function is strict in the starting value.
+foldr' :: (a -> b -> b) -> b -> Set a -> b
+foldr' f = wrapVS id (T.foldrWithKey' (const . f))
+{-# INLINE foldr' #-}
+
+-- | /O(k')/. The minimal element of a set.
+findMin :: Set a -> a
+findMin = wrapS fst T.findMin
+{-# INLINE findMin #-}
+
+-- | /O(k)/. The maximal element of a set.
+findMax :: Set a -> a
+findMax = wrapS fst T.findMax
+{-# INLINE findMax #-}
+
+-- | /O(k')/. Delete the minimal element. Returns an empty set if the
+-- set is empty.
+deleteMin :: Set a -> Set a
+deleteMin = wrapS Set T.deleteMin
+{-# INLINE deleteMin #-}
+
+-- | /O(k)/. Delete the maximal element. Returns an empty set if the
+-- set is empty.
+deleteMax :: Set a -> Set a
+deleteMax = wrapS Set T.deleteMax
+{-# INLINE deleteMax #-}
+
+-- | /O(k')/. Delete and find the minimal element.
+--
+-- > deleteFindMin set = (findMin set, deleteMin set)
+deleteFindMin :: Set a -> (a, Set a)
+deleteFindMin = wrapS (fst *** Set) T.deleteFindMin
+{-# INLINE deleteFindMin #-}
+
+-- | /O(k)/. Delete and find the maximal element.
+--
+-- > deleteFindMax set = (findMax set, deleteMax set)
+deleteFindMax :: Set a -> (a, Set a)
+deleteFindMax = wrapS (fst *** Set) T.deleteFindMax
+{-# INLINE deleteFindMax #-}
+
+-- | /O(k')/. Retrieves the minimal key of the set, and the set
+-- stripped of that element, or 'Nothing' if passed an empty set.
+minView :: Set a -> Maybe (a, Set a)
+minView = wrapS (fmap (fst *** Set)) T.minViewWithKey
+{-# INLINE minView #-}
+
+-- | /O(k)/. Retrieves the maximal key of the set, and the set
+-- stripped of that element, or 'Nothing' if passed an empty set.
+maxView :: Set a -> Maybe (a, Set a)
+maxView = wrapS (fmap (fst *** Set)) T.maxViewWithKey
+{-# INLINE maxView #-}
+
+-- | /O(n)/. Convert the set to an ascending list of elements.
+toAscList :: Set a -> [a]
+toAscList = toList
+
+-- | /O(n)/. Convert the set to a descending list of elements.
+toDescList :: Set a -> [a]
+toDescList = reverse . toAscList
+
+-- | /O(n)/. Build a set from an ascending list in linear time.
+-- /The precondition (input list is ascending) is not checked./
+fromAscList :: (CritBitKey a) => [a] -> Set a
+fromAscList = liftFromList T.fromAscList
+
+-- | /O(n)/. Build a set from an ascending list in linear time.
+-- /The precondition (input list is ascending) is not checked./
+fromDistinctAscList :: (CritBitKey a) => [a] -> Set a
+fromDistinctAscList = liftFromList T.fromDistinctAscList
+
+-- | Wraps tree operation to set operation
+wrapS :: (r -> q) -> (CritBit a () -> r) -> Set a -> q
+wrapS f g (Set s) = f $ g s
+{-# INLINE wrapS #-}
+
+-- | Wraps (value, tree) operation to (value, set) operation
+wrapVS :: (r -> q) -> (t -> CritBit a () -> r) -> t -> Set a -> q
+wrapVS f g a (Set s) = f $ g a s
+{-# INLINE wrapVS #-}
+
+-- | Wraps (tree, tree) operation to (set, set) operation
+wrapSS :: (r -> q) -> (CritBit a () -> CritBit a () -> r) -> Set a -> Set a -> q
+wrapSS f g (Set s1) (Set s2) = f $ g s1 s2
+{-# INLINE wrapSS #-}
+
+liftFromList :: ([(a, ())] -> CritBit a ()) -> [a] -> Set a
+liftFromList f xs = Set . f . zip xs . repeat $ ()
+{-# INLINE liftFromList #-}
diff --git a/Data/CritBit/Tree.hs b/Data/CritBit/Tree.hs
--- a/Data/CritBit/Tree.hs
+++ b/Data/CritBit/Tree.hs
@@ -1,421 +1,1520 @@
{-# 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 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- |
+-- Module : Data.CritBit.Tree
+-- Copyright : (c) Bryan O'Sullivan and others 2013-2014
+-- 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
+ , lookupLT
+ , lookupLE
+
+ -- * 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 Control.Applicative (Applicative(..), (<$>), (<|>))
+import Control.Arrow (second, (***))
+import Data.CritBit.Core
+import Data.CritBit.Types.Internal
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Monoid(..))
+import Data.Traversable (Traversable(traverse))
+import Prelude hiding (foldl, foldr, lookup, null, map, filter)
+import qualified Data.Array as A
+import qualified Data.Foldable as Foldable
+import qualified Data.List as List
+
+instance CritBitKey k => Monoid (CritBit k v) where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+instance CritBitKey k => Traversable (CritBit k) where
+ traverse f m = traverseWithKey (\_ v -> f v) m
+
+infixl 9 !, \\
+
+-- | /O(k)/. Find the value at a key.
+-- Calls 'error' when the element can not be found.
+--
+-- > fromList [("a",5), ("b",3)] ! "c" Error: element not in the map
+-- > fromList [("a",5), ("b",3)] ! "a" == 5
+(!) :: CritBitKey k => CritBit k v -> k -> v
+(!) m k = lookupWith err id k m
+ where err = error "CritBit.!: given key is not an element in the map"
+{-# INLINABLE (!) #-}
+
+-- | Same as 'difference'.
+(\\) :: CritBitKey k => CritBit k v -> CritBit k w -> CritBit k v
+(\\) m n = difference m n
+{-# INLINABLE (\\) #-}
+
+-- | /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 Empty
+
+-- | /O(k)/. 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(k)/. 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(k)/. 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(k)/. 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
+delete k t@(CritBit root) = go root empty CritBit
+ where
+ go i@(Internal left right _ _) _ cont
+ | k `onLeft` i = go left (cont right) $ ((cont $!) . setLeft i)
+ | otherwise = go right (cont left) $ ((cont $!) . setRight i)
+ go (Leaf lk _) other _
+ | k == lk = other
+ | otherwise = t
+ go Empty _ _ = t
+{-# INLINABLE delete #-}
+
+-- | /O(k)/. 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@.
+--
+-- > let f x = if x == 5 then Just 50 else Nothing
+-- > update f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 50), ("b",3)]
+-- > update f "c" (fromList [("b",3), ("a",5)]) == fromList [("a", 50), ("b",3)]
+-- > update f "b" (fromList [("b",3), ("a",5)]) == singleton "a" 5
+update :: (CritBitKey k) => (v -> Maybe v) -> k -> CritBit k v -> CritBit k v
+update f = updateWithKey (const f)
+{-# INLINABLE update #-}
+
+-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
+-- to the new value @y@.
+--
+-- > let f k x = if x == 5 then Just (x + fromEnum (k < "d")) else Nothing
+-- > updateWithKey f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 6), ("b",3)]
+-- > updateWithKey f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
+-- > updateWithKey f "b" (fromList [("a",5), ("b",3)]) == singleton "a" 5
+updateWithKey :: (CritBitKey k) => (k -> v -> Maybe v) -> k -> CritBit k v
+ -> CritBit k v
+updateWithKey f k = snd . updateLookupWithKey f k
+{-# INLINABLE updateWithKey #-}
+
+-- | /O(k)/. 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.
+--
+-- > let f k x = x + 1
+-- > adjustWithKey f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 6), ("b",3)]
+-- > adjustWithKey f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
+-- > adjustWithKey f "c" empty == empty
+adjust :: (CritBitKey k) => (v -> v) -> k -> CritBit k v -> CritBit k v
+adjust f = updateWithKey (\_ v -> Just (f v))
+{-# INLINABLE adjust #-}
+
+-- | /O(k)/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+--
+-- > let f k x = x + fromEnum (k < "d")
+-- > adjustWithKey f "a" (fromList [("b",3), ("a",5)]) == fromList [("a", 6), ("b",3)]
+-- > adjustWithKey f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
+-- > adjustWithKey f "c" empty == empty
+adjustWithKey :: (CritBitKey k) => (k -> v -> v) -> k -> CritBit k v
+ -> CritBit k v
+adjustWithKey f = updateWithKey (\k v -> Just (f k v))
+{-# INLINABLE adjustWithKey #-}
+
+-- | /O(k)/. 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(k)/. 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 r = lookupOrd (GT ==) k r
+{-# INLINABLE lookupGT #-}
+
+-- | /O(k)/. Find smallest key greater than or equal to the given one and
+-- return the corresponding (key, value) pair.
+--
+-- > lookupGE "aa" (fromList [("a",3), ("b",5)]) == Just("b",5)
+-- > lookupGE "b" (fromList [("a",3), ("b",5)]) == Just("b",5)
+-- > lookupGE "bb" (fromList [("a",3), ("b",5)]) == Nothing
+lookupGE :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v)
+lookupGE k r = lookupOrd (LT /=) k r
+{-# INLINABLE lookupGE #-}
+
+-- | /O(k)/. Find largest key smaller than the given one and
+-- return the corresponding (key, value) pair.
+--
+-- > lookupLT "aa" (fromList [("a",3), ("b",5)]) == Just ("a",3)
+-- > lookupLT "a" (fromList [("a",3), ("b",5)]) == Nothing
+lookupLT :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v)
+lookupLT k r = lookupOrd (LT ==) k r
+{-# INLINABLE lookupLT #-}
+
+-- | /O(k)/. Find largest key smaller than or equal to the given one and
+-- return the corresponding (key, value) pair.
+--
+-- > lookupGE "bb" (fromList [("aa",3), ("b",5)]) == Just("b",5)
+-- > lookupGE "aa" (fromList [("aa",3), ("b",5)]) == Just("aa",5)
+-- > lookupGE "a" (fromList [("aa",3), ("b",5)]) == Nothing
+lookupLE :: (CritBitKey k) => k -> CritBit k v -> Maybe (k, v)
+lookupLE k r = lookupOrd (GT /=) k r
+{-# INLINABLE lookupLE #-}
+
+-- | /O(k)/. Common part of lookupXX functions.
+lookupOrd :: (CritBitKey k) =>
+ (Ordering -> Bool) -> k -> CritBit k v -> Maybe (k, v)
+lookupOrd accepts k m = findPosition (const id) finish toLeft toRight k m
+ where
+ finish _ Empty = Nothing
+ finish diff (Leaf lk lv)
+ | accepts (diffOrd diff) = pair lk lv
+ | otherwise = Nothing
+ finish diff i@(Internal{}) = case diffOrd diff of
+ LT -> ifLT i
+ GT -> ifGT i
+ EQ -> error "Data.CritBit.Tree.lookupOrd.finish: Unpossible."
+
+ toLeft i = (<|> ifGT (iright i))
+ toRight i = (<|> ifLT (ileft i))
+ pair a b = Just (a, b)
+ ifGT = test GT leftmost
+ ifLT = test LT rightmost
+ test v f node
+ | accepts v = f Nothing pair node
+ | otherwise = Nothing
+{-# INLINE lookupOrd #-}
+
+-- | /O(k)/. 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' ins empty
+ where
+ ins t (k,x) = insert k x t
+{-# INLINABLE fromList #-}
+
+-- | /O(k)/. Build a map from a list of key\/value pairs
+-- with a combining function. See also 'fromAscListWith'.
+--
+-- > fromListWith (+) [("a",5), ("b",5), ("b",3), ("a",3), ("a",5)] ==
+-- > fromList [("a",13), ("b",8)]
+-- > fromListWith (+) [] == empty
+fromListWith :: (CritBitKey k) => (v -> v -> v) -> [(k,v)] -> CritBit k v
+fromListWith f xs = fromListWithKey (const f) xs
+{-# INLINABLE fromListWith #-}
+
+-- | /O(k)/. Build a map from a list of key\/value pairs
+-- with a combining function. See also 'fromAscListWithKey'.
+--
+-- > let f key a1 a2 = byteCount key + a1 + a2
+-- > fromListWithKey f [("a",5), ("b",5), ("b",3), ("a",3), ("a",5)] ==
+-- > fromList [("a",16), ("b",10)]
+-- > fromListWithKey f [] == empty
+fromListWithKey :: (CritBitKey k) => (k -> v -> v -> v) -> [(k,v)] -> CritBit k v
+fromListWithKey f xs
+ = List.foldl' ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+{-# INLINABLE fromListWithKey #-}
+
+-- | /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 0
+ where
+ go (Internal{..}) !c = go iright (go ileft c)
+ go (Leaf{}) c = c + 1
+ go Empty c = c
+
+-- | /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 = Foldable.foldl f z m
+{-# INLINE 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 = foldlWithKey' (\a _ v -> f a v) z m
+{-# INLINABLE foldl' #-}
+
+-- | /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 = Foldable.foldr f z m
+{-# INLINE 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 = foldrWithKey' (const f) z m
+{-# INLINABLE foldr' #-}
+
+-- | /O(n)/. Return all the elements of the map in ascending order of
+-- their keys.
+--
+-- > elems (fromList [("b",5), ("a",3)]) == [3,5]
+-- > elems empty == []
+elems :: CritBit k v -> [v]
+elems m = foldr (:) [] m
+{-# INLINE elems #-}
+
+-- | /O(n)/. An alias for 'toAscList'. Return all key/value pairs in the map in
+-- ascending order.
+--
+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+-- > assocs empty == []
+assocs :: CritBit k v -> [(k,v)]
+assocs m = toAscList m
+
+-- | /O(n)/. Return set of all keys of the map.
+--
+-- > keysSet (fromList [("b",5), ("a",3)]) == Set.fromList ["a", "b"]
+-- > keysSet empty == []
+keysSet :: CritBit k v -> Set k
+keysSet m = Set (fmap (const ()) m)
+{-# INLINABLE keysSet #-}
+
+-- | /O(n)/. Build a map from a set of keys and a function which for each key
+-- computes its value.
+--
+-- > fromSet (\k -> length k) (Data.IntSet.fromList ["a", "bb"]) == fromList [("a",1), ("bb",2)]
+-- > fromSet undefined Data.IntSet.empty == empty
+fromSet :: (k -> v) -> Set k -> CritBit k v
+fromSet f (Set s) = mapWithKey (const . f) s
+{-# INLINABLE fromSet #-}
+
+-- | /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 (CritBit root) = go root []
+ where
+ go (Internal{..}) acc = go ileft $ go iright acc
+ go (Leaf k _) acc = k : acc
+ go Empty acc = acc
+{-# INLINABLE keys #-}
+
+unionL :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v
+unionL a b = unionWithKey (\_ x _ -> x) a b
+{-# INLINABLE unionL #-}
+
+unionR :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v
+unionR a b = unionWithKey (\_ x _ -> x) b a
+{-# INLINABLE unionR #-}
+
+-- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased
+-- union of @t1@ and @t2@.
+--
+-- It prefers @t1@ when duplicate keys are encountered,
+-- i.e. (@'union' == 'unionWith' 'const'@).
+--
+-- > union (fromList [("a", 5), ("b", 3)]) (fromList [("a", 4), ("c", 7)]) == fromList [("a", 5), ("b", "3"), ("c", 7)]
+union :: (CritBitKey k) => CritBit k v -> CritBit k v -> CritBit k v
+union a b = unionL a b
+{-# INLINE union #-}
+
+-- | Union with a combining function.
+--
+-- > let l = fromList [("a", 5), ("b", 3)]
+-- > let r = fromList [("A", 5), ("b", 7)]
+-- > unionWith (+) l r == fromList [("A",5),("a",5),("b",10)]
+unionWith :: (CritBitKey k) => (v -> v -> v)
+ -> CritBit k v -> CritBit k v -> CritBit k v
+unionWith f a b = unionWithKey (const f) a b
+
+-- | Union with a combining function.
+--
+-- > let f key new_value old_value = byteCount key + new_value + old_value
+-- > let l = fromList [("a", 5), ("b", 3)]
+-- > let r = fromList [("A", 5), ("C", 7)]
+-- > unionWithKey f l r == fromList [("A",5),("C",7),("a",5),("b",3)]
+unionWithKey :: (CritBitKey k) => (k -> v -> v -> v)
+ -> CritBit k v -> CritBit k v -> CritBit k v
+unionWithKey f (CritBit lt) (CritBit rt) = CritBit (top lt rt)
+ where
+ -- Assumes that empty nodes exist only on the top level
+ top Empty b = b
+ top a Empty = a
+ top a b = go a (minKey a) b (minKey b)
+
+ -- Each node is followed by the minimum key in that node.
+ -- This trick assures that overall time spend by minKey in O(n+m)
+ go a@(Leaf ak av) _ b@(Leaf bk bv) _
+ | ak == bk = Leaf ak (f ak av bv)
+ | otherwise = fork a ak b bk
+ go a@(Leaf{}) ak b@(Internal{}) bk =
+ leafBranch a b bk (splitB a ak b bk) (fork a ak b bk)
+ go a@(Internal{}) ak b@(Leaf{}) bk =
+ leafBranch b a ak (splitA a ak b bk) (fork a ak b bk)
+ go a@(Internal al ar abyte abits) ak b@(Internal bl br bbyte bbits) bk
+ | (dbyte, dbits) < min (abyte, abits) (bbyte, bbits) = fork a ak b bk
+ | otherwise =
+ case compare (abyte, abits) (bbyte, bbits) of
+ LT -> splitA a ak b bk
+ GT -> splitB a ak b bk
+ EQ -> setBoth' a (go al ak bl bk) (go ar (minKey ar) br (minKey br))
+ where
+ Diff dbyte dbits _ = followPrefixes ak bk
+ -- Assumes that empty nodes exist only on the top level
+ go _ _ _ _ = error "Data.CritBit.Tree.unionWithKey.go: Empty"
+
+ splitA a@(Internal al ar _ _) ak b bk =
+ switch bk a (go al ak b bk) ar al (go ar (minKey ar) b bk)
+ splitA _ _ _ _ =
+ error "Data.CritBit.Tree.unionWithKey.splitA: unpossible"
+ {-# INLINE splitA #-}
+
+ splitB a ak b@(Internal bl br _ _) bk =
+ switch ak b (go a ak bl bk) br bl (go a ak br (minKey br))
+ splitB _ _ _ _ =
+ error "Data.CritBit.Tree.unionWithKey.splitB: unpossible"
+ {-# INLINE splitB #-}
+
+ fork a ak b bk = internal (followPrefixes ak bk) b a
+ {-# INLINE fork #-}
+{-# INLINEABLE unionWithKey #-}
+
+-- | The union of a list of maps:
+-- (@'unions' == 'List.foldl' 'union' 'empty'@).
+--
+-- > unions [(fromList [("a", 5), ("b", 3)]), (fromList [("a", 6), ("c", 7)]), (fromList [("a", 9), ("b", 5)])]
+-- > == fromList [("a", 5), ("b", 4), (c, 7)]
+-- > unions [(fromList [("a", 9), ("b", 8)]), (fromList [("ab", 5), ("c",7)]), (fromList [("a", 5), ("b", 3)])]
+-- > == fromList [("a", 9), ("ab", 5), ("b", 8), ("c", 7)]
+unions :: (CritBitKey k) => [CritBit k v] -> CritBit k v
+unions cs = List.foldl' union empty cs
+
+-- | The union of a list of maps, with a combining operation:
+-- (@'unionsWith' f == 'List.foldl' ('unionWith' f) 'empty'@).
+--
+-- > unionsWith (+) [(fromList [("a",5), ("b", 3)]), (fromList [("a", 3), ("c", 7)]), (fromList [("a", 5), ("b", 5)])]
+-- > == fromList [("a", 12), ("b", 8), ("c")]
+unionsWith :: (CritBitKey k) => (v -> v -> v) -> [CritBit k v] -> CritBit k v
+unionsWith f cs = List.foldl' (unionWith f) empty cs
+
+-- | /O(n+m)/. Difference of two maps.
+-- | Return data in the first map not existing in the second map.
+--
+-- > let l = fromList [("a", 5), ("b", 3)]
+-- > let r = fromList [("A", 2), ("b", 7)]
+-- > difference l r == fromList [("a", 5)]
+difference :: (CritBitKey k) => CritBit k v -> CritBit k w -> CritBit k v
+difference a b = differenceWithKey (\_ _ _ -> Nothing) a b
+{-# INLINEABLE difference #-}
+
+-- | /O(n+m)/. Difference with a combining function.
+-- | When two equal keys are encountered, the combining function is applied
+-- | to the values of theese keys. If it returns 'Nothing', the element is
+-- | discarded (proper set difference). If it returns (@'Just' y@),
+-- | the element is updated with a new value @y@.
+--
+-- > let f av bv = if av == 3 then Just (av + bv) else Nothing
+-- > let l = fromList [(pack "a", 5), (pack "b", 3), (pack "c", 8)]
+-- > let r = fromList [(pack "a", 2), (pack "b", 7), (pack "d", 8)]
+-- > differenceWith f l r == fromList [(pack "b", 10), (pack "c", 8)]
+differenceWith :: (CritBitKey k) => (v -> w -> Maybe v)
+ -> CritBit k v -> CritBit k w -> CritBit k v
+differenceWith f a b = differenceWithKey (const f) a b
+{-# INLINEABLE differenceWith #-}
+
+-- | /O(n+m)/. Difference with a combining function.
+-- | When two equal keys are encountered, the combining function is applied
+-- | to the key and both values. If it returns 'Nothing', the element is
+-- | discarded (proper set difference). If it returns (@'Just' y@),
+-- | the element is updated with a new value @y@.
+--
+-- > let f k av bv = if k == "b" then Just (length k + av + bv) else Nothing
+-- > let l = fromList [("a", 5), ("b", 3), ("c", 8)]
+-- > let r = fromList [("a", 2), ("b", 7), ("d", 8)]
+-- > differenceWithKey f l r == fromList [("b", 11), ("c", 8)]
+differenceWithKey :: (CritBitKey k) => (k -> v -> w -> Maybe v)
+ -> CritBit k v -> CritBit k w -> CritBit k v
+differenceWithKey = binarySetOpWithKey id
+{-# INLINEABLE differenceWithKey #-}
+
+-- | /O(n+m)/. Intersection of two maps.
+-- | Return data in the first map for the keys existing in both maps.
+--
+-- > let l = fromList [("a", 5), ("b", 3)]
+-- > let r = fromList [("A", 2), ("b", 7)]
+-- > intersection l r == fromList [("b", 3)]
+intersection :: (CritBitKey k) => CritBit k v -> CritBit k w -> CritBit k v
+intersection a b = intersectionWithKey (\_ x _ -> x) a b
+{-# INLINEABLE intersection #-}
+
+-- | /O(n+m)/. Intersection with a combining function.
+--
+-- > let l = fromList [("a", 5), ("b", 3)]
+-- > let r = fromList [("A", 2), ("b", 7)]
+-- > intersectionWith (+) l r == fromList [("b", 10)]
+intersectionWith :: (CritBitKey k) => (v -> w -> x)
+ -> CritBit k v -> CritBit k w -> CritBit k x
+intersectionWith f a b = intersectionWithKey (const f) a b
+{-# INLINEABLE intersectionWith #-}
+
+-- | /O(n+m)/. Intersection with a combining function.
+--
+-- > let f key new_value old_value = length key + new_value + old_value
+-- > let l = fromList [("a", 5), ("b", 3)]
+-- > let r = fromList [("A", 2), ("b", 7)]
+-- > intersectionWithKey f l r == fromList [("b", 11)]
+intersectionWithKey :: (CritBitKey k) => (k -> v -> w -> x)
+ -> CritBit k v -> CritBit k w -> CritBit k x
+intersectionWithKey f = binarySetOpWithKey (const Empty) f'
+ where
+ f' k v1 v2 = Just (f k v1 v2)
+
+-- | Perform binary set operation on two maps.
+binarySetOpWithKey :: (CritBitKey k)
+ => (Node k v -> Node k x) -- ^ Process unmatched node in first map
+ -> (k -> v -> w -> Maybe x) -- ^ Process matching values
+ -> CritBit k v -- ^ First map
+ -> CritBit k w -- ^ Second map
+ -> CritBit k x
+binarySetOpWithKey left both (CritBit lt) (CritBit rt) = CritBit $ top lt rt
+ where
+ -- Assumes that empty nodes exist only on the top level.
+ top Empty _ = Empty
+ top a Empty = left a
+ top a b = go a (minKey a) b (minKey b)
+
+ -- Each node is followed by the minimum key in that node.
+ -- This trick assures that overall time spend by minKey is O(n+m).
+ go a@(Leaf ak av) _ (Leaf bk bv) _
+ | ak == bk = case both ak av bv of
+ Just v -> Leaf ak v
+ Nothing -> Empty
+ | otherwise = left a
+ go a@(Leaf{}) ak b@(Internal{}) bk =
+ leafBranch a b bk (splitB a ak b bk) (left a)
+ go a@(Internal{}) ak b@(Leaf{}) bk =
+ leafBranch b a ak (splitA a ak b bk) (left a)
+ go a@(Internal al ar abyte abits) ak b@(Internal bl br bbyte bbits) bk =
+ case compare (abyte, abits) (bbyte, bbits) of
+ LT -> splitA a ak b bk
+ GT -> splitB a ak b bk
+ EQ -> setBoth' a (go al ak bl bk) (go ar (minKey ar) br (minKey br))
+ -- Assumes that empty nodes exist only on the top level.
+ go _ _ _ _ = error "Data.CritBit.Tree.binarySetOpWithKey.go: Empty"
+
+ splitA a@(Internal al ar _ _) ak b bk =
+ switch bk a (go al ak b bk) (left ar) (left al) (go ar (minKey ar) b bk)
+ splitA _ _ _ _ =
+ error "Data.CritBit.Tree.binarySetOpWithKey.splitA: unpossible"
+ {-# INLINE splitA #-}
+
+ splitB a ak b@(Internal bl br _ _) bk =
+ switch ak b (go a ak bl bk) Empty Empty (go a ak br (minKey br))
+ splitB _ _ _ _ =
+ error "Data.CritBit.Tree.binarySetOpWithKey.splitB: unpossible"
+ {-# INLINE splitB #-}
+{-# INLINEABLE binarySetOpWithKey #-}
+
+-- | Detect whether branch in 'Internal' node comes 'before' or
+-- 'after' branch initiated by 'Leaf'.
+leafBranch :: CritBitKey k => Node k v -> Node k w -> k -> t -> t -> t
+leafBranch (Leaf lk _) i@(Internal{}) sk before after
+ | followPrefixes lk sk `above` i = after
+ | otherwise = before
+leafBranch _ _ _ _ _ = error "Data.CritBit.Tree.leafBranch: unpossible"
+{-# INLINE leafBranch #-}
+
+-- | Select child to link under node 'n' by 'k'.
+switch :: (CritBitKey k) => k -> Node k v -> Node k w -> Node k w
+ -> Node k w -> Node k w -> Node k w
+switch k n a0 b0 a1 b1
+ | k `onLeft` n = setBoth' n a0 b0
+ | otherwise = setBoth' n a1 b1
+{-# INLINE switch #-}
+
+-- | Extract minimum key from the subtree.
+minKey :: (CritBitKey k) => Node k v -> k
+minKey n = leftmost
+ (error "Data.CritBit.Tree.minKey: Empty")
+ const n
+{-# INLINE minKey #-}
+
+-- | Extract maximum key from the subtree.
+maxKey :: (CritBitKey k) => Node k v -> k
+maxKey n = rightmost
+ (error "Data.CritBit.Tree.maxKey: Empty")
+ const n
+{-# INLINE maxKey #-}
+
+-- | Sets both children to the parent node.
+setBoth' :: Node k v -> Node k w -> Node k w -> Node k w
+setBoth' _ Empty b = b
+setBoth' _ a Empty = a
+setBoth' (Internal _ _ byte bits) !a !b = Internal a b byte bits
+setBoth' _ _ _ = error "Data.CritBit.Tree.setBoth': unpossible"
+{-# INLINE setBoth' #-}
+
+setBoth :: Node k v -> Node k w -> Node k w -> Node k w
+setBoth (Internal _ _ byte bits) !a !b = Internal a b byte bits
+setBoth _ _ _ = error "Data.CritBit.Tree.setBoth: unpossible"
+{-# INLINE setBoth #-}
+
+-- | /O(n)/. Apply a function to all values.
+--
+-- > map show (fromList [("b",5), ("a",3)]) == fromList [("b","5"), ("a","3")]
+map :: (CritBitKey k) => (v -> w) -> CritBit k v -> CritBit k w
+map = fmap
+
+-- | /O(k)/.
+-- @mapKeys f@ applies the function @f@ to the keys of the map.
+--
+-- If @f@ maps multiple keys to the same new key, the new key is
+-- associated with the value of the greatest of the original keys.
+--
+-- > let f = fromString . (++ "1") . show
+-- > mapKeys f (fromList [("a", 5), ("b", 3)]) == fromList ([("a1", 5), ("b1", 3)])
+-- > mapKeys (\ _ -> "a") (fromList [("a", 5), ("b", 3)]) == singleton "a" 3
+mapKeys :: (CritBitKey k2)
+ => (k1 -> k2)
+ -> CritBit k1 v -> CritBit k2 v
+mapKeys f m = mapKeysWith (\_ v -> v) f m
+{-# INLINABLE mapKeys #-}
+
+-- | /O(k)/.
+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- The size of the result may be smaller if @f@ maps two or more distinct
+-- keys to the same new key. In this case the associated values will be
+-- combined using @c@.
+--
+-- > mapKeysWith (+) (\ _ -> "a") (fromList [("b",1), ("a",2), ("d",3), ("c",4)]) == singleton "a" 10
+mapKeysWith :: (CritBitKey k2)
+ => (v -> v -> v)
+ -> (k1 -> k2)
+ -> CritBit k1 v -> CritBit k2 v
+mapKeysWith c f m = foldrWithKey ins empty m
+ where ins k v nm = insertWith c (f k) v nm
+{-# INLINABLE mapKeysWith #-}
+
+-- | /O(k)/.
+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
+-- is strictly monotonic.
+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapKeysMonotonic f s == mapKeys f s
+-- > where ls = keys s
+--
+-- This means that @f@ maps distinct original keys to distinct resulting keys.
+-- This function has slightly better performance than 'mapKeys'.
+--
+-- > mapKeysMonotonic (\ k -> succ k) (fromList [("a",5), ("b",3)]) == fromList [("b",5), ("c",3)]
+mapKeysMonotonic :: (CritBitKey k)
+ => (a -> k) -> CritBit a v -> CritBit k v
+mapKeysMonotonic f m = foldlWithKey (insertRight f) empty m
+{-# INLINABLE mapKeysMonotonic #-}
+
+insertRight :: CritBitKey k
+ => (a -> k) -> CritBit k v -> a -> v -> CritBit k v
+insertRight f (CritBit root) ok v
+ | Empty <- root = CritBit $ Leaf k v
+ | otherwise = CritBit $ go root
+ where
+ k = f ok
+ go i@(Internal _ right _ _)
+ | diff `above` i = append i
+ | otherwise = setRight' i $ go right
+ go i = append i
+
+ append i = internal diff i (Leaf k v)
+
+ diff = followPrefixes k $ maxKey root
+{-# INLINE insertRight #-}
+
+-- | /O(n)/. Convert the map to a list of key/value pairs where the keys are in
+-- ascending order.
+--
+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
+toAscList :: CritBit k v -> [(k,v)]
+toAscList m = foldrWithKey f [] m
+ where f k v vs = (k,v) : vs
+
+-- | /O(n)/. Convert the map to a list of key/value pairs where the keys are in
+-- descending order.
+--
+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]
+toDescList :: CritBit k v -> [(k,v)]
+toDescList m = foldlWithKey f [] m
+ where f vs k v = (k,v):vs
+
+-- | /O(n)/. Build a tree from an ascending list in linear time.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
+fromAscList :: (CritBitKey k) => [(k, a)] -> CritBit k a
+fromAscList = fromAscListWithKey (\_ x _ -> x)
+{-# INLINABLE fromAscList #-}
+
+-- | /O(n)/. Build a tree from an ascending list in linear time
+-- with a combining function for equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
+fromAscListWith :: (CritBitKey k) => (a -> a -> a) -> [(k,a)] -> CritBit k a
+fromAscListWith f = fromAscListWithKey (const f)
+{-# INLINABLE fromAscListWith #-}
+
+-- | /O(n)/. Build a map from an ascending list in linear time with a
+-- combining function for equal keys.
+-- /The precondition (input list is ascending) is not checked./
+--
+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
+fromAscListWithKey :: (CritBitKey k) =>
+ (k -> a -> a -> a) -> [(k,a)] -> CritBit k a
+fromAscListWithKey _ [] = empty
+fromAscListWithKey _ [(k, v)] = singleton k v
+fromAscListWithKey f kvs = build 0 1 upper fromContext kvs RCNil
+ -- This implementation is based on the idea of binary search in
+ -- a suffix array using LCP array.
+ --
+ -- Input list is converted to array and processed top-down.
+ -- When building tree for interval we finds the length of
+ -- the common prefix of all keys in this interval. We never
+ -- compare known common prefixes, thus reducing number of
+ -- comparisons. Then we merge trees, building recursively on
+ -- halves of this interval.
+ --
+ -- This algorithm runs in /O(n+K)/ time, where /K/ is the total
+ -- length of all keys minus . When many keys have equal prefixes,
+ -- the second summand may be much smaller.
+ --
+ -- See also:
+ --
+ -- Manber, Udi; Myers, Gene (1990). "Suffix arrays: a new method for
+ -- on-line string searches". In Proceedings of the first annual
+ -- ACM-SIAM symposium on Discrete algorithms 90 (319): 327.
+ where
+ upper = length kvs - 1
+ array = fst . (A.listArray (0, upper) kvs A.!)
+
+ fromContext = add (Diff 0 0 0)
+ (const $ \(RCCons node _ _ _) -> CritBit node)
+
+ build z left right cont xs cx
+ | left == right = add diffI cont xs cx
+ | otherwise = (build diffO left mid $
+ build diffO (mid + 1) right cont) xs cx
+ where
+ mid = (left + right - 1) `div` 2
+ diffO = followPrefixesByteFrom z (fst (head xs)) (array right)
+ diffI = followPrefixesFrom z (fst (head xs)) (array right)
+ {-# INLINE build #-}
+
+ add (Diff byte bits _) cont (x:xs) cx
+ | bits == 0x1ff = let (k, v1) = x; (_, v2) = head xs
+ in cont ((k, f k v2 v1) : tail xs) cx
+ | otherwise = cont xs $ pop (uncurry Leaf x) cx
+ where
+ pop right cs@(RCCons left cbyte cbits cs')
+ | cbyte > byte || cbyte == byte && cbits > bits
+ = pop (Internal left right cbyte cbits) cs'
+ | otherwise = RCCons right byte bits cs
+ pop right cs = RCCons right byte bits cs
+ add _ _ _ _ = error "CritBit.fromAscListWithKey.add: Unpossible"
+ {-# INLINE add #-}
+{-# INLINABLE fromAscListWithKey #-}
+
+-- | /O(n)/. Build a tree from an ascending list of distinct elements
+-- in linear time.
+-- /The precondition is not checked./
+--
+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True
+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
+fromDistinctAscList :: (CritBitKey k) => [(k,a)] -> CritBit k a
+fromDistinctAscList = fromAscListWithKey undefined
+{-# INLINABLE fromDistinctAscList #-}
+
+-- | One-hole CritBit context focused on the maximum leaf
+data RightContext k v
+ = RCNil
+ | RCCons !(Node k v) !Int !BitMask !(RightContext k v)
+
+-- | /O(n)/. Filter all values that satisfy the predicate.
+--
+-- > filter (> "a") (fromList [("5","a"), ("3","b")]) == fromList [("3","b")]
+-- > filter (> "x") (fromList [("5","a"), ("3","b")]) == empty
+-- > filter (< "a") (fromList [("5","a"), ("3","b")]) == empty
+filter :: (v -> Bool) -> CritBit k v -> CritBit k v
+filter p m = filterWithKey (const p) m
+
+-- | /O(n)/. Filter all keys\/values that satisfy the predicate.
+--
+-- > filterWithKey (\k _ -> k > "4") (fromList [("5","a"), ("3","b")]) == fromList[("5","a")]
+filterWithKey :: (k -> v -> Bool) -> CritBit k v -> CritBit k v
+filterWithKey p (CritBit root) = CritBit $ go root
+ where
+ go i@(Internal left right _ _) = setBoth' i (go left) (go right)
+ go leaf@(Leaf k v) | p k v = leaf
+ go _ = Empty
+{-# INLINABLE filterWithKey #-}
+
+-- | /O(n)/. Map values and collect the 'Just' results.
+--
+-- > let f x = if x == 5 then Just 10 else Nothing
+-- > mapMaybe f (fromList [("a",5), ("b",3)]) == singleton "a" 10
+mapMaybe :: (a -> Maybe b) -> CritBit k a -> CritBit k b
+mapMaybe = mapMaybeWithKey . const
+
+-- | /O(n)/. Map keys\/values and collect the 'Just' results.
+--
+-- > let f k v = if k == "a" then Just ("k,v: " ++ show k ++ "," ++ show v) else Nothing
+-- > mapMaybeWithKey f (fromList [("a",5), ("b",3)]) == singleton "a" "k,v: \"a\",3"
+mapMaybeWithKey :: (k -> v -> Maybe v') -> CritBit k v -> CritBit k v'
+mapMaybeWithKey f (CritBit root) = CritBit $ go root
+ where
+ go i@(Internal left right _ _) = setBoth' i (go left) (go right)
+ go (Leaf k v) = maybe Empty (Leaf k) $ f k v
+ go Empty = Empty
+{-# INLINABLE mapMaybeWithKey #-}
+
+-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
+--
+-- > let f a = if a < 5 then Left a else Right a
+-- > mapEither f (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
+-- > == (fromList [("b",3), ("x",1)], fromList [("a",5), ("z",7)])
+-- >
+-- > mapEither (\ a -> Right a) (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
+-- > == (empty, fromList [("a",5), ("b",3), ("x",1), ("z",7)])
+mapEither :: (a -> Either b c) -> CritBit k a -> (CritBit k b, CritBit k c)
+mapEither = mapEitherWithKey . const
+
+-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
+--
+-- > let f k a = if k < "c" then Left (k ++ k) else Right (a * 2)
+-- > mapEitherWithKey f (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
+-- > == (fromList [("a","aa"), ("b","bb")], fromList [("x",2), ("z",14)])
+-- >
+-- > mapEitherWithKey (\_ a -> Right a) (fromList [("a",5), ("b",3), ("x",1), ("z",7)])
+-- > == (empty, fromList [("x",1), ("b",3), ("a",5), ("z",7)])
+mapEitherWithKey :: (k -> v -> Either v1 v2)
+ -> CritBit k v -> (CritBit k v1, CritBit k v2)
+mapEitherWithKey f (CritBit root) = (CritBit *** CritBit) $ go root
+ where
+ go i@(Internal l r _ _) = (setBoth' i ll rl, setBoth' i lr rr)
+ where
+ (ll, lr) = go l
+ (rl, rr) = go r
+ go (Leaf k v) = case f k v of
+ Left v' -> (Leaf k v', Empty)
+ Right v' -> (Empty, Leaf k v')
+ go Empty = (Empty, Empty)
+{-# INLINABLE mapEitherWithKey #-}
+
+-- | /O(k)/. The expression (@'split' k map@) is a pair
+-- @(map1,map2)@ where the keys in @map1@ are smaller than @k@ and the
+-- keys in @map2@ larger than @k@. Any key equal to @k@ is found in
+-- neither @map1@ nor @map2@.
+--
+-- > split "a" (fromList [("b",1), ("d",2)]) == (empty, fromList [("b",1), ("d",2)])
+-- > split "b" (fromList [("b",1), ("d",2)]) == (empty, singleton "d" 2)
+-- > split "c" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, singleton "d" 2)
+-- > split "d" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, empty)
+-- > split "e" (fromList [("b",1), ("d",2)]) == (fromList [("b",1), ("d",2)], empty)
+split :: (CritBitKey k) => k -> CritBit k v -> (CritBit k v, CritBit k v)
+-- Note that this is nontrivially faster than an implementation
+-- in terms of 'splitLookup'.
+split k m = CritBit *** CritBit $
+ findPosition (const id) finish goLeft goRight k m
+ where
+ finish _ Empty = (Empty, Empty)
+ finish diff node = case diffOrd diff of
+ LT -> (node, Empty)
+ GT -> (Empty, node)
+ EQ -> (Empty, Empty)
+
+ goLeft i (lt, Empty) = (lt, iright i)
+ goLeft i (lt, gt ) = (lt, setLeft i gt)
+
+ goRight i (Empty, gt) = (ileft i, gt)
+ goRight i (lt , gt) = (setRight i lt, gt)
+{-# INLINABLE split #-}
+
+-- | /O(k)/. The expression (@'splitLookup' k map@) splits a map just
+-- like 'split' but also returns @'lookup' k map@.
+--
+-- > splitLookup "a" (fromList [("b",1), ("d",2)]) == (empty, Nothing, fromList [("b",1), ("d",2)])
+-- > splitLookup "b" (fromList [("b",1), ("d",2)]) == (empty, Just 1, singleton "d" 2)
+-- > splitLookup "c" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, Nothing, singleton "d" 2)
+-- > splitLookup "d" (fromList [("b",1), ("d",2)]) == (singleton "b" 1, Just 2, empty)
+-- > splitLookup "e" (fromList [("b",1), ("d",2)]) == (fromList [("b",1), ("d",2)], Nothing, empty)
+splitLookup :: (CritBitKey k) => k -> CritBit k v
+ -> (CritBit k v, Maybe v, CritBit k v)
+splitLookup k m = (\(lt, eq, gt) -> (CritBit lt, eq, CritBit gt)) $
+ findPosition (const id) finish goLeft goRight k m
+ where
+ finish _ Empty = (Empty, Nothing, Empty)
+ finish diff node = case diffOrd diff of
+ LT -> (node, Nothing , Empty)
+ GT -> (Empty, Nothing , node )
+ EQ -> (Empty, leaf node, Empty)
+
+ leaf (Leaf _ v) = Just v
+ leaf _ = error "Data.CritBit.Tree.splitLookup.leaf: Unpossible."
+
+ goLeft i (lt, eq, Empty) = (lt, eq, iright i)
+ goLeft i (lt, eq, gt ) = (lt, eq, setLeft i gt)
+
+ goRight i (Empty, eq, gt) = (ileft i , eq, gt)
+ goRight i (lt , eq, gt) = (setRight i lt, eq, gt)
+{-# INLINABLE splitLookup #-}
+
+-- | /O(n+m)/. This function is defined as
+-- (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
+isSubmapOf :: (CritBitKey k, Eq v) => CritBit k v -> CritBit k v -> Bool
+isSubmapOf = isSubmapOfBy (==)
+{-# INLINABLE isSubmapOf #-}
+
+-- | /O(n+m)/. The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
+-- all keys in @t1@ are in map @t2@, and when @f@ returns 'True' when
+-- applied to their respective values. For example, the following
+-- expressions are all 'True':
+--
+-- > isSubmapOfBy (==) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
+-- > isSubmapOfBy (<=) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
+-- > isSubmapOfBy (==) (fromList [("a",1),("b",2)]) (fromList [("a",1),("b",2)])
+--
+-- But the following are all 'False':
+--
+-- > isSubmapOfBy (==) (fromList [("a",2)]) (fromList [("a",1),("b",2)])
+-- > isSubmapOfBy (<) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
+-- > isSubmapOfBy (==) (fromList [("a",1),("b",2)]) (fromList [("a",1)])
+isSubmapOfBy :: (CritBitKey k) => (a -> b -> Bool) -> CritBit k a
+ -> CritBit k b -> Bool
+isSubmapOfBy f a b = submapTypeBy f a b /= No
+{-# INLINABLE isSubmapOfBy #-}
+
+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
+isProperSubmapOf :: (CritBitKey k, Eq v) => CritBit k v -> CritBit k v -> Bool
+isProperSubmapOf = isProperSubmapOfBy (==)
+{-# INLINABLE isProperSubmapOf #-}
+
+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+-- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
+-- @m1@ and @m2@ are not equal,
+-- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
+-- applied to their respective values. For example, the following
+-- expressions are all 'True':
+--
+-- > isProperSubmapOfBy (==) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
+-- > isProperSubmapOfBy (<=) (fromList [("a",0)]) (fromList [("a",1),("b",2)])
+--
+-- But the following are all 'False':
+--
+-- > isProperSubmapOfBy (==) (fromList [("a",1),("b",2)]) (fromList [("a",1),("b",2)])
+-- > isProperSubmapOfBy (==) (fromList ["a",1),("b",2)]) (fromList [("a",1)])
+-- > isProperSubmapOfBy (<) (fromList [("a",1)]) (fromList [("a",1),("b",2)])
+isProperSubmapOfBy :: (CritBitKey k) =>
+ (a -> b -> Bool) -> CritBit k a -> CritBit k b -> Bool
+isProperSubmapOfBy f a b = submapTypeBy f a b == Yes
+{-# INLINABLE isProperSubmapOfBy #-}
+
+data SubmapType = No | Yes | Equal deriving (Eq, Ord)
+submapTypeBy :: (CritBitKey k) =>
+ (a -> b -> Bool) -> CritBit k a -> CritBit k b -> SubmapType
+submapTypeBy f (CritBit root1) (CritBit root2) = top root1 root2
+ where
+ -- Assumes that empty nodes exist only on the top level
+ top Empty Empty = Equal
+ top Empty _ = Yes
+ top _ Empty = No
+ top a b = go a (minKey a) b (minKey b)
+ {-# INLINE top #-}
+
+ -- Each node is followed by the minimum key in that node.
+ -- This trick assures that overall time spend by minKey in O(n+m)
+ go (Leaf ak av) _ (Leaf bk bv) _
+ | ak == bk = if f av bv then Equal else No
+ | otherwise = No
+ go a@(Leaf{}) ak b@(Internal{}) bk =
+ leafBranch a b bk (splitB a ak b bk) No
+ go (Internal{}) _ (Leaf{}) _ = No
+ go a@(Internal al ar abyte abits) ak b@(Internal bl br bbyte bbits) bk =
+ case compare (abyte, abits) (bbyte, bbits) of
+ LT -> No
+ GT -> splitB a ak b bk
+ EQ -> min (go al ak bl bk) (go ar (minKey ar) br (minKey br))
+ -- Assumes that empty nodes exist only on the top level
+ go _ _ _ _ = error "Data.CritBit.Tree.isSubmapOfBy.go: Empty"
+
+ splitB a ak b@(Internal bl br _ _) bk = if t == No then No else Yes
+ where
+ t = if ak `onLeft` b then go a ak bl bk
+ else go a ak br (minKey br)
+
+ splitB _ _ _ _ =
+ error "Data.CritBit.Tree.isSubmapOfBy.splitB: unpossible"
+ {-# INLINE splitB #-}
+{-# INLINABLE submapTypeBy #-}
+
+-- | /O(minimum K)/. The minimal key of the map. Calls 'error' if the map
+-- is empty.
+--
+-- > findMin (fromList [("b",3), ("a",5)]) == ("a",5)
+-- > findMin empty Error: empty map has no minimal element
+findMin :: CritBit k v -> (k,v)
+findMin (CritBit root) = leftmost emptyMap (,) root
+ where
+ emptyMap = error "CritBit.findMin: empty map has no minimal element"
+{-# INLINABLE findMin #-}
+
+-- | /O(k)/. The maximal key of the map. Calls 'error' if the map
+-- is empty.
+--
+-- > findMax empty Error: empty map has no minimal element
+findMax :: CritBit k v -> (k,v)
+findMax (CritBit root) = rightmost emptyMap (,) root
+ where
+ emptyMap = error "CritBit.findMax: empty map has no maximal element"
+{-# INLINABLE findMax #-}
+
+-- | /O(k')/. Delete the minimal key. Returns an empty map if the
+-- map is empty.
+--
+-- > deleteMin (fromList [("a",5), ("b",3), ("c",7)]) == fromList [("b",3), ("c",7)]
+-- > deleteMin empty == empty
+deleteMin :: CritBit k v -> CritBit k v
+deleteMin m = updateMinWithKey (\_ _ -> Nothing) m
+{-# INLINABLE deleteMin #-}
+
+-- | /O(k)/. Delete the maximal key. Returns an empty map if the
+-- map is empty.
+--
+-- > deleteMin (fromList [("a",5), ("b",3), ("c",7)]) == fromList [("a",5), ("b","3")]
+-- > deleteMin empty == empty
+deleteMax :: CritBit k v -> CritBit k v
+deleteMax m = updateMaxWithKey (\_ _ -> Nothing) m
+{-# INLINABLE deleteMax #-}
+
+-- | /O(k')/. Delete and find the minimal element.
+--
+-- > deleteFindMin (fromList [("a",5), ("b",3), ("c",10)]) == (("a",5), fromList[("b",3), ("c",10)])
+-- > deleteFindMin Error: can not return the minimal element of an empty map
+deleteFindMin :: CritBit k v -> ((k, v), CritBit k v)
+deleteFindMin = fromMaybe (error msg) . minViewWithKey
+ where msg = "CritBit.deleteFindMin: cannot return the minimal \
+ \element of an empty map"
+{-# INLINABLE deleteFindMin #-}
+
+-- | /O(k)/. Delete and find the maximal element.
+--
+-- > deleteFindMax (fromList [("a",5), ("b",3), ("c",10)]) == (("c",10), fromList[("a",5), ("b",3)])
+-- > deleteFindMax Error: can not return the maximal element of an empty map
+deleteFindMax :: CritBit k v -> ((k, v), CritBit k v)
+deleteFindMax = fromMaybe (error msg) . maxViewWithKey
+ where msg = "CritBit.deleteFindMax: cannot return the minimal \
+ \element of an empty map"
+{-# INLINABLE deleteFindMax #-}
+
+-- | /O(k')/. Retrieves the value associated with minimal key of the
+-- map, and the map stripped of that element, or 'Nothing' if passed an
+-- empty map.
+--
+-- > minView (fromList [("a",5), ("b",3)]) == Just (5, fromList [("b",3)])
+-- > minView empty == Nothing
+minView :: CritBit k v -> Maybe (v, CritBit k v)
+minView = fmap (first snd) . minViewWithKey
+{-# INLINABLE minView #-}
+
+-- | /O(k)/. Retrieves the value associated with maximal key of the
+-- map, and the map stripped of that element, or 'Nothing' if passed an
+-- empty map.
+--
+-- > maxView (fromList [("a",5), ("b",3)]) == Just (3, fromList [("a",5)])
+-- > maxView empty == Nothing
+maxView :: CritBit k v -> Maybe (v, CritBit k v)
+maxView = fmap (first snd) . maxViewWithKey
+{-# INLINABLE maxView #-}
+
+-- | /O(k')/. Retrieves the minimal (key,value) pair of the map, and
+-- the map stripped of that element, or 'Nothing' if passed an empty map.
+--
+-- > minViewWithKey (fromList [("a",5), ("b",3)]) == Just (("a",5), fromList [("b",3)])
+-- > minViewWithKey empty == Nothing
+minViewWithKey :: CritBit k v -> Maybe ((k, v), CritBit k v)
+minViewWithKey (CritBit root) = go root CritBit
+ where
+ go (Internal (Leaf lk lv) right _ _) cont = Just ((lk,lv), cont right)
+ go i@(Internal left _ _ _) cont = go left $ (cont $!) . setLeft i
+ go (Leaf lk lv) _ = Just ((lk,lv),empty)
+ go _ _ = Nothing
+{-# INLINABLE minViewWithKey #-}
+
+-- | /O(k)/. Retrieves the maximal (key,value) pair of the map, and
+-- the map stripped of that element, or 'Nothing' if passed an empty map.
+--
+-- > maxViewWithKey (fromList [("a",5), ("b",3)]) == Just (("b",3), fromList [("a",5)])
+-- > maxViewWithKey empty == Nothing
+maxViewWithKey :: CritBit k v -> Maybe ((k,v), CritBit k v)
+maxViewWithKey (CritBit root) = go root CritBit
+ where
+ go (Internal left (Leaf lk lv) _ _) cont = Just ((lk,lv), cont left)
+ go i@(Internal _ right _ _) cont = go right $ (cont $!) . setRight i
+ go (Leaf lk lv) _ = Just ((lk,lv),empty)
+ go _ _ = Nothing
+{-# INLINABLE maxViewWithKey #-}
+
+first :: (a -> b) -> (a,c) -> (b,c)
+first f (x,y) = (f x, y)
+{-# INLINE first #-}
+
+-- | /O(k')/. Update the value at the minimal key.
+--
+-- > updateMin (\ a -> Just (a + 7)) (fromList [("a",5), ("b",3)]) == fromList [("a",12), ("b",3)]
+-- > updateMin (\ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("b",3)]
+updateMin :: (v -> Maybe v) -> CritBit k v -> CritBit k v
+updateMin f m = updateMinWithKey (const f) m
+{-# INLINABLE updateMin #-}
+
+-- | /O(k)/. Update the value at the maximal key.
+--
+-- > updateMax (\ a -> Just (a + 7)) (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",10)]
+-- > updateMax (\ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("a",5)]
+updateMax :: (v -> Maybe v) -> CritBit k v -> CritBit k v
+updateMax f m = updateMaxWithKey (const f) m
+{-# INLINABLE updateMax #-}
+
+-- | /O(k')/. Update the value at the minimal key.
+--
+-- > updateMinWithKey (\ k a -> Just (length k + a)) (fromList [("a",5), ("b",3)]) == fromList [("a",6), ("b",3)]
+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("b",3)]
+updateMinWithKey :: (k -> v -> Maybe v) -> CritBit k v -> CritBit k v
+updateMinWithKey maybeUpdate (CritBit root) = CritBit $ go root
+ where
+ go i@(Internal left _ _ _) = setLeft' i (go left)
+ go (Leaf k v) = maybe Empty (Leaf k) $ maybeUpdate k v
+ go _ = Empty
+{-# INLINABLE updateMinWithKey #-}
+
+-- | /O(k)/. Update the value at the maximal key.
+--
+-- > updateMaxWithKey (\ k a -> Just (length k + a)) (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",4)]
+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [("a",5), ("b",3)]) == fromList [("a",5)]
+updateMaxWithKey :: (k -> v -> Maybe v) -> CritBit k v -> CritBit k v
+updateMaxWithKey maybeUpdate (CritBit root) = CritBit $ go root
+ where
+ go i@(Internal _ right _ _) = setRight' i (go right)
+ go (Leaf k v) = maybe Empty (Leaf k) $ maybeUpdate k v
+ go _ = Empty
+{-# INLINABLE updateMaxWithKey #-}
+
+-- | /O(k)/. 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 = insertLookupGen (flip const) (\_ v _ -> v)
+{-# INLINABLE insert #-}
+
+-- | /O(k)/. Insert with a function, combining new value and old value.
+-- @'insertWith' f key value cb@
+-- will insert the pair (key, value) into @cb@ 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 (+) "a" 1 (fromList [("a",5), ("b",3)]) == fromList [("a",6), ("b",3)]
+-- > insertWith (+) "c" 7 (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("c",7)]
+-- > insertWith (+) "x" 5 empty == singleton "x" 5
+--
+insertWith :: CritBitKey k =>
+ (v -> v -> v) -> k -> v -> CritBit k v -> CritBit k v
+insertWith f = insertLookupGen (flip const) (const f)
+{-# INLINABLE insertWith #-}
+
+-- | /O(n)/. Apply a function to all values.
+--
+-- > let f key x = show key ++ ":" ++ show x
+-- > mapWithKey f (fromList [("a",5), ("b",3)]) == fromList [("a","a:5"), ("b","b:3")]
+mapWithKey :: (k -> v -> w) -> CritBit k v -> CritBit k w
+mapWithKey f (CritBit root) = CritBit (go root)
+ where
+ go i@(Internal l r _ _) = setBoth i (go l) (go r)
+ go (Leaf k v) = Leaf k (f k v)
+ go Empty = Empty
+{-# INLINABLE mapWithKey #-}
+
+-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating
+-- argument through the map in descending order of keys.
+mapAccumRWithKey :: (CritBitKey k) => (a -> k -> v -> (a, w)) -> a
+ -> CritBit k v -> (a, CritBit k w)
+mapAccumRWithKey f start (CritBit root) = second CritBit (go start root)
+ where
+ go a i@(Internal{..}) = let (a0, r') = go a iright
+ (a1, l') = go a0 ileft
+ in (a1, setBoth i l' r')
+ go a (Leaf k v) = let (a0, w) = f a k v in (a0, Leaf k w)
+ go a Empty = (a, Empty)
+{-# INLINABLE mapAccumRWithKey #-}
+
+-- | /O(n)/.
+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
+--
+-- That is, behaves exactly like a regular 'traverse' except
+-- that the traversing function also has access to the key associated
+-- with a value.
+--
+-- > let f key value = show key ++ ":" ++ show value
+-- > traverseWithKey (\k v -> if odd v then Just (f k v) else Nothing) (fromList [("a",3), ("b",5)]) == Just (fromList [("a","a:3"), ("b","b:5")])
+-- > traverseWithKey (\k v -> if odd v then Just (f k v) else Nothing) (fromList [("c", 2)]) == Nothing
+traverseWithKey :: (CritBitKey k, Applicative t)
+ => (k -> v -> t w)
+ -> CritBit k v
+ -> t (CritBit k w)
+traverseWithKey f (CritBit root) = fmap CritBit (go root)
+ where
+ go i@(Internal l r _ _) = setBoth i <$> go l <*> go r
+ go (Leaf k v) = Leaf k <$> f k v
+ go Empty = pure Empty
+{-# INLINABLE traverseWithKey #-}
+
+-- | /O(n)/. The function 'mapAccum' threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a b = (a ++ show b, show b ++ "X")
+-- > mapAccum f "Everything: " (fromList [("a",5), ("b",3)]) == ("Everything: 53", fromList [("a","5X"), ("b","3X")])
+mapAccum :: (CritBitKey k)
+ => (a -> v -> (a, w))
+ -> a
+ -> CritBit k v
+ -> (a, CritBit k w)
+mapAccum f = mapAccumWithKey (\a _ v -> f a v)
+{-# INLINE mapAccum #-}
+
+-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
+-- argument through the map in ascending order of keys.
+--
+-- > let f a k b = (a ++ " " ++ show k ++ "-" ++ show b, show b ++ "X")
+-- > mapAccumWithKey f "Everything: " (fromList [("a",5), ("b",3)]) == ("Everything: a-5 b-3", fromList [("a","5X"), ("b","3X")])
+mapAccumWithKey :: (CritBitKey k)
+ => (a -> k -> v -> (a, w))
+ -> a
+ -> CritBit k v
+ -> (a, CritBit k w)
+mapAccumWithKey f start (CritBit root) = second CritBit (go start root)
+ where
+ go a i@(Internal{..}) = let (a0, l') = go a ileft
+ (a1, r') = go a0 iright
+ in (a1, setBoth i l' r')
+
+ go a (Leaf k v) = let (a0, w) = f a k v in (a0, Leaf k w)
+ go a Empty = (a, Empty)
+{-# INLINABLE mapAccumWithKey #-}
+
+-- | /O(k)/. 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 'CritBit'. In short : @'lookup' k ('alter'
+-- f k m) = f ('lookup' k m)@.
+--
+-- > let f _ = Nothing
+-- > alter f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3)]
+-- > alter f "a" (fromList [("a",5), ("b",3)]) == fromList [("b",3)]
+-- >
+-- > let f _ = Just 1
+-- > alter f "c" (fromList [("a",5), ("b",3)]) == fromList [("a",5), ("b",3), ("c",1)]
+-- > alter f "a" (fromList [(5,"a"), (3,"b")]) == fromList [("a",1), ("b",3)]
+alter :: (CritBitKey k)
+ => (Maybe v -> Maybe v) -> k -> CritBit k v -> CritBit k v
+alter f !k m = findPosition (const CritBit) finish setLeft' setRight' k m
+ where
+ finish _ Empty = maybe Empty (Leaf k) $ f Nothing
+ finish diff (Leaf _ v) | diffOrd diff == EQ =
+ maybe Empty (Leaf k) $ f (Just v)
+ finish diff node = maybe node (internal diff node . Leaf k) $ f Nothing
+{-# INLINABLE alter #-}
+
+-- | /O(n)/. Partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+--
+-- > partitionWithKey (\ k _ -> k < "b") (fromList [("a",5), ("b",3)]) == (fromList [("a",5)], fromList [("b",3)])
+-- > partitionWithKey (\ k _ -> k < "c") (fromList [(5,"a"), (3,"b")]) == (fromList [("a",5), ("b",3)], empty)
+-- > partitionWithKey (\ k _ -> k > "c") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [("a",5), ("b",3)])
+partitionWithKey :: (CritBitKey k)
+ => (k -> v -> Bool)
+ -> CritBit k v
+ -> (CritBit k v, CritBit k v)
+partitionWithKey f (CritBit root) = CritBit *** CritBit $ go root
+ where
+ go l@(Leaf k v)
+ | f k v = (l,Empty)
+ | otherwise = (Empty,l)
+ go i@(Internal{..}) = (setBoth' i l1 r1, setBoth' i l2 r2)
+ where
+ (!l1,!l2) = go ileft
+ (!r1,!r2) = go iright
+ go _ = (Empty,Empty)
+{-# INLINABLE partitionWithKey #-}
+
+-- | /O(n)/. Partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+--
+-- > partition (> 4) (fromList [("a",5), ("b",3)]) == (fromList [("a",5)], fromList [("b",3)])
+-- > partition (< 6) (fromList [("a",5), ("b",3)]) == (fromList [("a",5), ("b",3)], empty)
+-- > partition (> 6) (fromList [("a",5), ("b",3)]) == (empty, fromList [("a",5), ("b",3)])
+partition :: (CritBitKey k)
+ => (v -> Bool)
+ -> CritBit k v
+ -> (CritBit k v, CritBit k v)
+partition f m = partitionWithKey (const f) m
+{-# INLINABLE partition #-}
diff --git a/Data/CritBit/Types/Internal.hs b/Data/CritBit/Types/Internal.hs
--- a/Data/CritBit/Types/Internal.hs
+++ b/Data/CritBit/Types/Internal.hs
@@ -1,29 +1,44 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-}
-- |
-- Module : Data.CritBit.Types.Internal
--- Copyright : (c) Bryan O'Sullivan 2013
+-- Copyright : (c) Bryan O'Sullivan and others 2013-2014
-- License : BSD-style
-- Maintainer : bos@serpentine.com
-- Stability : experimental
-- Portability : GHC
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#include "MachDeps.h"
+#endif
+
module Data.CritBit.Types.Internal
(
CritBitKey(..)
, CritBit(..)
+ , Set(..)
, BitMask
, Node(..)
+ , foldlWithKey
+ , foldlWithKey'
+ , foldrWithKey
+ , foldrWithKey'
, toList
) where
import Control.DeepSeq (NFData(..))
-import Data.Bits ((.|.), (.&.), shiftL, shiftR)
+import Data.Bits (Bits, (.|.), (.&.), shiftL, shiftR)
import Data.ByteString (ByteString)
+import Data.Foldable hiding (toList)
+import Data.Monoid (Monoid(..))
import Data.Text ()
import Data.Text.Internal (Text(..))
-import Data.Word (Word16)
+import Data.Word (Word, Word8, Word16, Word32, Word64)
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.Text.Array as T
+import qualified Data.Vector.Generic as G
+import qualified Data.Vector.Unboxed as U
+import qualified Data.Vector as V
type BitMask = Word16
@@ -35,7 +50,9 @@
, 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.
+ -- will have every bit other than 0x8 set, hence 0x1F7
+ -- (the ninth bit is set because we're using 9 bits for representing
+ -- bytes).
}
| Leaf k v
| Empty
@@ -52,10 +69,83 @@
rnf (Leaf k v) = rnf k `seq` rnf v
rnf Empty = ()
+instance Functor (Node k) where
+ fmap f i@(Internal l r _ _) = i { ileft = fmap f l, iright = fmap f r }
+ fmap f (Leaf k v) = Leaf k (f v)
+ fmap _ Empty = Empty
+
+instance Foldable (Node k) where
+ foldl f z m = foldlWithKey (\a _ v -> f a v) z (CritBit m)
+ foldr f z m = foldrWithKey (\_ v a -> f v a) z (CritBit m)
+
+ foldMap f (Internal l r _ _) = mappend (foldMap f l) (foldMap f r)
+ foldMap f (Leaf _ v) = f v
+ foldMap _ Empty = mempty
+ {-# INLINABLE foldMap #-}
+
+-- | /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' #-}
+
+-- | /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' #-}
+
+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 #-}
+
+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 #-}
+
-- | A crit-bit tree.
-newtype CritBit k v = CritBit {
- cbRoot :: Node k v
- } deriving (Eq, NFData)
+newtype CritBit k v = CritBit (Node k v)
+ deriving (Eq, NFData, Functor, Foldable)
instance (Show k, Show v) => Show (CritBit k v) where
show t = "fromList " ++ show (toList t)
@@ -106,6 +196,83 @@
| otherwise = 0
{-# INLINE getByte #-}
+#if WORD_SIZE_IN_BITS == 64
+# define WORD_SHIFT 3
+#else
+# define WORD_SHIFT 2
+#endif
+
+instance CritBitKey (U.Vector Word8) where
+ byteCount = G.length
+ getByte = getByteV 0
+
+instance CritBitKey (U.Vector Word16) where
+ byteCount = (`shiftL` 1) . G.length
+ getByte = getByteV 1
+
+instance CritBitKey (U.Vector Word32) where
+ byteCount = (`shiftL` 2) . G.length
+ getByte = getByteV 2
+
+instance CritBitKey (U.Vector Word64) where
+ byteCount = (`shiftL` 3) . G.length
+ getByte = getByteV 3
+
+instance CritBitKey (U.Vector Word) where
+ byteCount = (`shiftL` WORD_SHIFT) . G.length
+ getByte = getByteV WORD_SHIFT
+
+instance CritBitKey (U.Vector Char) where
+ byteCount = (`shiftL` 2) . G.length
+ getByte = getByteV_ fromEnum 2
+
+instance CritBitKey (V.Vector Word8) where
+ byteCount = G.length
+ getByte = getByteV 0
+
+instance CritBitKey (V.Vector Word16) where
+ byteCount = (`shiftL` 1) . G.length
+ getByte = getByteV 1
+
+instance CritBitKey (V.Vector Word32) where
+ byteCount = (`shiftL` 2) . G.length
+ getByte = getByteV 2
+
+instance CritBitKey (V.Vector Word64) where
+ byteCount = (`shiftL` 3) . G.length
+ getByte = getByteV 3
+
+instance CritBitKey (V.Vector Word) where
+ byteCount = (`shiftL` WORD_SHIFT) . G.length
+ getByte = getByteV WORD_SHIFT
+
+instance CritBitKey (V.Vector Char) where
+ byteCount = (`shiftL` 2) . G.length
+ getByte = getByteV_ fromEnum 2
+
+getByteV :: (Bits a, Integral a, G.Vector v a) => Int -> v a -> Int -> Word16
+getByteV = getByteV_ id
+{-# INLINE getByteV #-}
+
+getByteV_ :: (Bits a, Integral a, G.Vector v b) =>
+ (b -> a) -> Int -> v b -> Int -> Word16
+getByteV_ convert shiftSize = \v n ->
+ if n < G.length v `shiftL` shiftSize
+ then reindex shiftSize n $ \wordOffset shiftRight ->
+ let word = convert (G.unsafeIndex v wordOffset)
+ byteInWord = (word `shiftR` shiftRight) .&. 255
+ in fromIntegral byteInWord .|. 256
+ else 0
+{-# INLINE getByteV_ #-}
+
+reindex :: Int -> Int -> (Int -> Int -> r) -> r
+reindex shiftSize n f = f wordOffset shiftRight
+ where
+ wordOffset = n `shiftR` shiftSize
+ shiftRight = (size - (n .&. size)) `shiftL` 3
+ where size = (1 `shiftL` shiftSize) - 1
+{-# INLINE reindex #-}
+
-- | /O(n)/. Convert the map to a list of key\/value pairs. The list
-- returned will be sorted in lexicographically ascending order.
--
@@ -117,3 +284,8 @@
go (Internal l r _ _) next = go l (go r next)
go (Leaf k v) next = (k,v) : next
go Empty next = next
+
+
+-- | A set based on crit-bit trees.
+newtype Set a = Set (CritBit a ())
+ deriving (Eq, NFData)
diff --git a/README.markdown b/README.markdown
--- a/README.markdown
+++ b/README.markdown
@@ -1,9 +1,13 @@
Crit-bit trees for Haskell
====
-This is the first purely functional implementation of crit-bit trees
-that I'm aware of.
+This is the first purely functional implementation of [crit-bit
+trees](http://cr.yp.to/critbit.html) that I'm aware of.
+A crit-bit tree is a key/value container that allows efficient lookups
+and ordered traversal for data that can be represented as a string of
+bits.
+
This package exists in part with education in mind:
* The core data structures are simple.
@@ -13,17 +17,17 @@
* 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.
+* Originally, I *deliberately* left the package incomplete. (It has
+ since been substantially fleshed out.) 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).
+* For some operations, they are much faster than `Data.Map` from the
+ `containers` package, while for others, they are slower.
* Compared to `Data.HashMap`, you get about the same lookup
performance, but also some features that a hash-based structure
@@ -78,13 +82,6 @@
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.
@@ -95,39 +92,41 @@
Set up a sandbox.
-The first time through, you need to download and install a ton of
+The first time through, you may 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
+ cabal sandbox init
+ cabal 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.
+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
+To actually build:
+ cabal build
+
Running the test suite
----
-Once you've built the code, you can run the entire test suite in a few
-seconds.
+Once you've built the code, you can run the entire test suite fairly
+quickly. This takes about 30 seconds on my oldish 8-core Mac laptop:
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`
+If you're feeling impatient, run a subset of the test suite:
+
+ dist/build/tests/tests -t properties/map/bytestring +RTS -N
+
+And if you want to explore, the `tests` program accepts a `--help`
option. Try it out.
@@ -195,14 +194,26 @@
formatting" review, and then you'll be sad too.
-Setting expectations
-====
+What your commits should look like
+----
-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).
+Please follow the guidelines below, as they make it easier to review
+your pull request and deal with your commits afterwards.
-But the main point of this is: have fun!
+* One logical idea per commit! If you want to add five functions,
+ that's fine, but please spread them across five commits.
+
+* Do not reorganize or refactor unrelated code in a commit whose
+ purpose is to add new code.
+
+* When you add a new function, add its tests and benchmarks in the
+ same commit.
+
+* Do not add trailing whitespace. Follow the same formatting
+ and naming conventions as you already see in the code around you.
+
+* Keep your maximum line length at 80 columns for everything except
+ lines of example code in documentation.
+
+(If you can't follow the guidelines, there's a good chance I'll ask
+you to fix your commits and resubmit them.)
diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs
--- a/benchmarks/Benchmarks.hs
+++ b/benchmarks/Benchmarks.hs
@@ -1,33 +1,40 @@
-{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, OverloadedStrings #-}
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.Foldable (foldMap)
+import Data.Functor.Identity (Identity(..))
import Data.Hashable (Hashable(..), hashByteArray)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, fromJust)
+import Data.Monoid (Sum(..),mappend)
import Data.Text.Array (aBA)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Internal (Text(..))
-import System.Environment (lookupEnv)
+import System.Environment (getEnv)
import System.IO (hPutStrLn, stderr)
import System.IO.Error (ioError, isDoesNotExistError)
import System.Random.MWC (GenIO, GenST, asGenST, create, uniform, uniformR)
+import qualified Control.Exception as Exc
import qualified Data.ByteString.Char8 as B
import qualified Data.CritBit.Map.Lazy as C
+import qualified Data.CritBit.Set as CSet
import qualified Data.HashMap.Lazy as H
import qualified Data.Map as Map
+import qualified Data.Set as Set
import qualified Data.Text as T
+import qualified Data.Trie as Trie
+import qualified Data.Trie.Convenience as TC
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
+import qualified Data.Vector.Unboxed as U
+import qualified Data.List as L
#if 0
instance Hashable Text where
@@ -35,9 +42,19 @@
{-# INLINE hash #-}
#endif
+#if !MIN_VERSION_bytestring(0,10,0)
+instance NFData B.ByteString
+#endif
+
instance (NFData a) => NFData (Trie.Trie a) where
rnf = rnf . Trie.toList
+forcePair :: (a,b) -> ()
+forcePair (a,b) = a `seq` b `seq` ()
+
+addvs :: (Num v) => k -> v -> v -> v
+addvs _ v1 v2 = v1 + v2
+
every k = go 0
where
go i (x:xs)
@@ -70,17 +87,31 @@
putStrLn $ show prob ++ " " ++ show (fromIntegral mismatches / nxs)
mapM_ go [0..100]
+mapFKey :: (Num v, C.CritBitKey k) => k -> v -> v
+mapFKey _ x = x + 1
+mapAccumFKey :: (C.CritBitKey k, Num v) => Int -> k -> v -> (Int, v)
+mapAccumFKey a _ v = (a + 1, v + 1)
+
+updateFKey :: Num v => k -> v -> Maybe v
+updateFKey _ v = Just $ v + 1
+
+updateFVal :: Num v => v -> Maybe v
+updateFVal v = updateFKey undefined v
+
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
+ fileName <- getEnv "WORDS" `Exc.catch` \(_::IOError) ->
+ return "/usr/share/dict/words"
+ ordKeys <- L.sort <$> (every 5 . B.words) <$> B.readFile fileName
+ `Exc.catch` \(err::IOError) -> do
+ when (isDoesNotExistError err) $
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)..]
+ prefix = B.concat $ L.map fst b_ordKVs
+ b_longKVs = map (first (B.append prefix)) b_ordKVs
b_revKVs = reverse b_ordKVs
b_randKVs <- do
gen <- create
@@ -90,10 +121,10 @@
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
+ b_critbit = C.fromList b_randKVs
+ b_map = Map.fromList b_randKVs
+ b_hashmap = H.fromList b_randKVs
+ b_trie = Trie.fromList b_randKVs
key = fst . head $ b_randKVs
b_critbit_1 = C.delete key b_critbit
b_map_1 = Map.delete key b_map
@@ -116,6 +147,18 @@
, bench "map" $ whnf Map.fromList kvs
, bench "hashmap" $ whnf H.fromList kvs
]
+ fromListWith kvs = [
+ bench "critbit" $ whnf (C.fromListWith (+)) kvs
+ , bench "map" $ whnf (Map.fromListWith (+)) kvs
+ , bench "hashmap" $ whnf (H.fromListWith (+)) kvs
+ , bench "trie" $ whnf (TC.fromListWith (+)) kvs
+ ]
+ fromListWithKey kvs = [
+ bench "critbit" $ whnf (C.fromListWithKey addvs) kvs
+ , bench "map" $ whnf (Map.fromListWithKey addvs) kvs
+ -- , bench "hashmap" $ whnf (H.fromListWithKey (\a b -> a+b)) kvs
+ -- , bench "trie" $ whnf (TC.fromListWithKey (\a b -> a+b)) kvs
+ ]
keyed critbit map hashmap trie =
[
bgroup "present" [
@@ -144,7 +187,7 @@
, 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,
+ Exc.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,
@@ -153,7 +196,8 @@
rnf b_trie_13, rnf b_trie_23]
defaultMain
[ bgroup "bytestring" [
- bgroup "fromList" [
+ bgroup "size" $ function whnf C.size Map.size H.size Trie.size
+ , bgroup "fromList" [
bgroup "ordered" $ fromList b_ordKVs ++
[ bench "trie" $ whnf Trie.fromList b_ordKVs ]
, bgroup "random" $ fromList b_randKVs ++
@@ -161,14 +205,149 @@
, bgroup "reversed" $ fromList b_revKVs ++
[ bench "trie" $ whnf Trie.fromList b_revKVs ]
]
+ , bgroup "fromListWith" [
+ bgroup "ordered" $ fromListWith b_ordKVs
+ , bgroup "random" $ fromListWith b_randKVs
+ , bgroup "reversed" $ fromListWith b_revKVs
+ ]
+ , bgroup "fromListWithKey" [
+ bgroup "ordered" $ fromListWithKey b_ordKVs
+ , bgroup "random" $ fromListWithKey b_randKVs
+ , bgroup "reversed" $ fromListWithKey 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 "insert" $ keyed (`C.insert` 1) (`Map.insert` 1)
+ (`H.insert` 1) (`Trie.insert` 1)
+ , bgroup "insertWith" [
+ bgroup "present" [
+ bench "critbit" $ whnf (C.insertWith (+) key 1) b_critbit
+ , bench "map" $ whnf (Map.insertWith (+) key 1) b_map
+ , bench "hashmap" $ whnf (H.insertWith (+) key 1) b_hashmap
+ ]
+ , bgroup "missing" [
+ bench "critbit" $ whnf (C.insertWith (+) key 1) b_critbit_1
+ , bench "map" $ whnf (Map.insertWith (+) key 1) b_map_1
+ , bench "hashmap" $ whnf (H.insertWith (+) key 1) b_hashmap_1
+ ]
+ ]
+ , bgroup "insertWithKey" [
+ bgroup "present" [
+ bench "critbit" $ whnf (C.insertWithKey addvs key 1) b_critbit
+ , bench "map" $ whnf (Map.insertWithKey addvs key 1) b_map
+ ]
+ , bgroup "missing" [
+ bench "critbit" $ whnf (C.insertWithKey addvs key 1) b_critbit_1
+ , bench "map" $ whnf (Map.insertWithKey addvs key 1) b_map_1
+ ]
+ ]
+ , bgroup "insertLookupWithKey" [
+ bgroup "present" [
+ bench "critbit" $
+ whnf (forcePair . C.insertLookupWithKey addvs key 1) b_critbit
+ , bench "map" $
+ whnf (forcePair . Map.insertLookupWithKey addvs key 1) b_map
+ ]
+ , bgroup "missing" [
+ bench "critbit" $
+ whnf (forcePair . C.insertLookupWithKey addvs key 1) b_critbit_1
+ , bench "map" $
+ whnf (forcePair . Map.insertLookupWithKey addvs key 1) b_map_1
+ ]
+ ]
+ , bgroup "adjust" $
+ let f v = (v + 10) in [
+ bgroup "present" [
+ bench "critbit" $ whnf (C.adjust f key) b_critbit
+ , bench "map" $ whnf (Map.adjust f key) b_map
+ ]
+ , bgroup "missing" [
+ bench "critbit" $ whnf (C.adjust f key) b_critbit_1
+ , bench "map" $ whnf (Map.adjust f key) b_map_1
+ ]
+ ]
+ , bgroup "adjustWithKey" $
+ let f k v = (v + fromIntegral (C.byteCount k)) in [
+ bgroup "present" [
+ bench "critbit" $ whnf (C.adjustWithKey f key) b_critbit
+ , bench "map" $ whnf (Map.adjustWithKey f key) b_map
+ , bench "trie" $ whnf (TC.adjustWithKey f key) b_trie
+ ]
+ , bgroup "missing" [
+ bench "critbit" $ whnf (C.adjustWithKey f key) b_critbit_1
+ , bench "map" $ whnf (Map.adjustWithKey f key) b_map_1
+ , bench "trie" $ whnf (TC.adjustWithKey f key) b_trie_1
+ ]
+ ]
+ , bgroup "updateWithKey" $
+ let f k v = Just (v + fromIntegral (C.byteCount k)) in [
+ bgroup "present" [
+ bench "critbit" $ whnf (C.updateWithKey f key) b_critbit
+ , bench "map" $ whnf (Map.updateWithKey f key) b_map
+ , bench "trie" $ whnf (TC.updateWithKey f key) b_trie
+ ]
+ , bgroup "missing" [
+ bench "critbit" $ whnf (C.updateWithKey f key) b_critbit_1
+ , bench "map" $ whnf (Map.updateWithKey f key) b_map_1
+ , bench "trie" $ whnf (TC.updateWithKey f key) b_trie_1
+ ]
+ ]
+ , bgroup "update" $
+ let f = updateFVal in [
+ bgroup "present" [
+ bench "critbit" $ whnf (C.update f key) b_critbit
+ , bench "map" $ whnf (Map.update f key) b_map
+ , bench "trie" $ whnf (TC.update f key) b_trie
+ ]
+ , bgroup "missing" [
+ bench "critbit" $ whnf (C.update f key) b_critbit_1
+ , bench "map" $ whnf (Map.update f key) b_map_1
+ , bench "trie" $ whnf (TC.update f key) b_trie_1
+ ]
+ ]
+ , bgroup "updateLookupWithKey" $
+ -- The Map implementation immediately returns a tuple with lazy values,
+ -- so we need to force it to evaluate the update.
+ let f k v = Just (v + fromIntegral (C.byteCount k)) in [
+ bgroup "present" [
+ bench "critbit" $ whnf
+ (snd . C.updateLookupWithKey f key) b_critbit
+ , bench "map" $ whnf
+ (snd . Map.updateLookupWithKey f key) b_map
+ ]
+ , bgroup "missing" [
+ bench "critbit" $ whnf
+ (snd . C.updateLookupWithKey f key) b_critbit_1
+ , bench "map" $ whnf
+ (snd . Map.updateLookupWithKey f key) b_map_1
+ ]
+ ]
, bgroup "lookup" $ keyed C.lookup Map.lookup H.lookup Trie.lookup
+#if MIN_VERSION_containers(0,5,0)
, bgroup "lookupGT" $ [
bench "critbit" $ whnf (C.lookupGT key) b_critbit
, bench "map" $ whnf (Map.lookupGT key) b_map
]
+ , bgroup "lookupGE" $ [
+ bench "critbit" $ whnf (C.lookupGE key) b_critbit
+ , bench "map" $ whnf (Map.lookupGE key) b_map
+ ]
+ , bgroup "lookupLT" $ [
+ bench "critbit" $ whnf (C.lookupLT key) b_critbit
+ , bench "map" $ whnf (Map.lookupLT key) b_map
+ ]
+ , bgroup "lookupLE" $ [
+ bench "critbit" $ whnf (C.lookupLE key) b_critbit
+ , bench "map" $ whnf (Map.lookupLE key) b_map
+ ]
+ , bgroup "fromSet" $
+ let
+ keys = map fst t_ordKVs
+ f = length . show
+ in [
+ bench "critbit" $ nf (C.fromSet f) (CSet.fromList keys)
+ , bench "map" $ nf (Map.fromSet f) (Set.fromList keys)
+ ]
+#endif
, 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)
@@ -176,14 +355,279 @@
(H.foldlWithKey' f 0) id
, bgroup "foldl'" $ function whnf (C.foldl' (+) 0) (Map.foldl' (+) 0)
(H.foldl' (+) 0) id
+ , bgroup "elems" $ function nf C.elems Map.elems H.elems Trie.elems
, bgroup "keys" $ function nf C.keys Map.keys H.keys Trie.keys
+ , bgroup "keysSet" [
+ bench "critbit" $ nf C.keysSet b_critbit
+ , bench "map" $ nf Map.keysSet b_map
+ ]
+ , bgroup "map" $ let f = (+3)
+ in function nf (C.map f) (Map.map f) (H.map f) (fmap f)
+ , bgroup "mapWithKey" [
+ bench "critbit" $ whnf (C.mapWithKey mapFKey) b_critbit
+ , bench "map" $ whnf (Map.mapWithKey mapFKey) b_map
+ ]
+ , bgroup "mapKeys" $ let f = (`mappend` "test") in [
+ bench "critbit" $ nf (C.mapKeys f) b_critbit
+ , bench "map" $ nf (Map.mapKeys f) b_map
+ ]
+ , bgroup "mapKeysWith" $ let f = (`mappend` "test") in [
+ bench "critbit" $ nf (C.mapKeysWith (+) f) b_critbit
+ , bench "map" $ nf (Map.mapKeysWith (+) f) b_map
+ ]
+ , bgroup "mapKeysMonotonic" $ let f = mappend "test" in [
+ bench "critbit" $ nf (C.mapKeysMonotonic f) b_critbit
+ , bench "map" $ nf (Map.mapKeysMonotonic f) b_map
+ ]
+ , bgroup "mapAccumWithKey" [
+ bench "critbit" $ whnf (C.mapAccumWithKey mapAccumFKey 0) b_critbit
+ , bench "map" $ whnf (Map.mapAccumWithKey mapAccumFKey 0) b_map
+ ]
+ , bgroup "mapAccumRWithKey" [
+ bench "critbit" $ whnf (C.mapAccumRWithKey mapAccumFKey 0) b_critbit
+ , bench "map" $ whnf (Map.mapAccumRWithKey mapAccumFKey 0) b_map
+ ]
, bgroup "union" $ twoMaps C.unionR Map.union H.union Trie.unionR
- ]
+ , bgroup "unionWith" [
+ bench "critbit" $ whnf (C.unionWith (+) b_critbit_13) b_critbit_23
+ , bench "map" $ whnf (Map.unionWith (+) b_map_13) b_map_23
+ ]
+ , bgroup "unionWithKey" [
+ bench "critbit" $ whnf (C.unionWithKey addvs b_critbit_13) b_critbit_23
+ , bench "map" $ whnf (Map.unionWithKey addvs b_map_13) b_map_23
+ ]
+ , bgroup "unions" [
+ bench "critbit" $ whnf C.unions [b_critbit_13, b_critbit_23]
+ , bench "map" $ whnf Map.unions [b_map_13, b_map_23]
+ ]
+ , bgroup "unionsWith" [
+ bench "critbit" $ whnf (C.unionsWith (+)) [b_critbit_13, b_critbit_23]
+ , bench "map" $ whnf (Map.unionsWith (+)) [b_map_13, b_map_23]
+ ]
+ , bgroup "difference" [
+ bench "critbit" $ whnf (C.difference b_critbit_13) b_critbit_23
+ , bench "map" $ whnf (Map.difference b_map_13) b_map_23
+ , bench "hashmap" $ whnf (H.difference b_hashmap_13) b_hashmap_23
+ ]
+ , bgroup "differenceWith" $ let f a b = Just (a + b) in [
+ bench "critbit" $ whnf (C.differenceWith f b_critbit_13) b_critbit_23
+ , bench "map" $ whnf (Map.differenceWith f b_map_13) b_map_23
+ ]
+ , bgroup "differenceWithKey" $ let f _ a b = Just(a + b) in [
+ bench "critbit" $ whnf (C.differenceWithKey f b_critbit_13) b_critbit_23
+ , bench "map" $ whnf (Map.differenceWithKey f b_map_13) b_map_23
+ ]
+ , bgroup "intersection" [
+ bench "critbit" $ whnf (C.intersection b_critbit_13) b_critbit_23
+ , bench "map" $ whnf (Map.intersection b_map_13) b_map_23
+ , bench "hashmap" $ whnf (H.intersection b_hashmap_13) b_hashmap_23
+ ]
+ , bgroup "intersectionWith" [
+ bench "critbit" $ whnf (C.intersectionWith (+) b_critbit_13) b_critbit_23
+ , bench "map" $ whnf (Map.intersectionWith (+) b_map_13) b_map_23
+ , bench "hashmap" $ whnf (H.intersectionWith (+) b_hashmap_13) b_hashmap_23
+ ]
+ , bgroup "intersectionWithKey" [
+ bench "critbit" $
+ whnf (C.intersectionWithKey addvs b_critbit_13) b_critbit_23
+ , bench "map" $
+ whnf (Map.intersectionWithKey addvs b_map_13) b_map_23
+ ]
+ , bgroup "toAscList" $ function nf C.toAscList Map.toAscList id id
+ , bgroup "toDescList" $ function nf C.toDescList Map.toDescList id id
+ , bgroup "fromAscList_short" [
+ bench "critbit" $ nf C.fromAscList b_ordKVs
+ , bench "map" $ nf Map.fromAscList b_ordKVs
+ ]
+ , bgroup "fromAscList_long" [
+ bench "critbit" $ nf C.fromAscList b_longKVs
+ , bench "map" $ nf Map.fromAscList b_longKVs
+ ]
+ , bgroup "fromAscListWith" [
+ bench "critbit" $ nf ( C.fromAscListWith (+)) b_ordKVs
+ , bench "map" $ nf (Map.fromAscListWith (+)) b_ordKVs
+ ]
+ , bgroup "fromAscListWithKey" [
+ bench "critbit" $ nf ( C.fromAscListWithKey (const (+))) b_ordKVs
+ , bench "map" $ nf (Map.fromAscListWithKey (const (+))) b_ordKVs
+ ]
+ , bgroup "fromAscDistinctList_short" [
+ bench "critbit" $ nf C.fromDistinctAscList b_ordKVs
+ , bench "map" $ nf Map.fromDistinctAscList b_ordKVs
+ ]
+ , bgroup "fromAscDistinctList_long" [
+ bench "critbit" $ nf C.fromDistinctAscList b_longKVs
+ , bench "map" $ nf Map.fromDistinctAscList b_longKVs
+ ]
+ , bgroup "filter" $ let p = (< 128)
+ p' = \e -> if p e then Just e else Nothing
+ in function nf (C.filter p) (Map.filter p)
+ (H.filter p) (Trie.filterMap p')
+ , bgroup "mapMaybe" $
+ let f x = if even x then Just (2 * x) else Nothing
+ in [
+ bench "critbit" $ whnf (C.mapMaybe f) b_critbit
+ , bench "map" $ whnf (Map.mapMaybe f) b_map
+ ]
+ , bgroup "mapMaybeWithKey" $
+ let f k v | even (fromIntegral v :: Int) =
+ Just (v + fromIntegral (C.byteCount k))
+ | otherwise = Nothing
+ in [
+ bench "critbit" $ whnf (C.mapMaybeWithKey f) b_critbit
+ , bench "map" $ whnf (Map.mapMaybeWithKey f) b_map
+ ]
+ , bgroup "mapEither" $
+ let f x = if even x then Left (2 * x) else Right (3 * x)
+ in [
+ bench "critbit" $ whnf (C.mapEither f) b_critbit
+ , bench "map" $ whnf (Map.mapEither f) b_map
+ ]
+ , bgroup "mapEitherWithKey" $
+ let f k v | even (fromIntegral v :: Int) =
+ Left (v + fromIntegral (C.byteCount k))
+ | otherwise = Right (2 * v)
+ in [
+ bench "critbit" $ nf (C.mapEitherWithKey f) b_critbit
+ , bench "map" $ nf (Map.mapEitherWithKey f) b_map
+ ]
+ , bgroup "split" [
+ bench "critbit" $ whnf (forcePair . C.split key) b_critbit
+ , bench "map" $ whnf (forcePair . Map.split key) b_map
+ ]
+ , bgroup "splitLookup" $
+ let forceTriple (a,_,b) = a `seq` b `seq` ()
+ in [
+ bench "critbit" $ whnf (forceTriple . C.splitLookup key) b_critbit
+ , bench "map" $ whnf (forceTriple . Map.splitLookup key) b_map
+ ]
+ , bgroup "isSubmapOf" [
+ bench "critbit" $ whnf (C.isSubmapOf b_critbit_1) b_critbit
+ , bench "map" $ whnf (Map.isSubmapOf b_map_1) b_map
+ ]
+ , bgroup "isSubmapOfBy" [
+ bench "critbit" $ whnf (C.isSubmapOfBy (<=) b_critbit_1) b_critbit
+ , bench "map" $ whnf (Map.isSubmapOfBy (<=) b_map_1) b_map
+ ]
+ , bgroup "isProperSubmapOf" [
+ bench "critbit" $ whnf (C.isProperSubmapOf b_critbit_1) b_critbit
+ , bench "map" $ whnf (Map.isProperSubmapOf b_map_1) b_map
+ ]
+ , bgroup "isProperSubmapOfBy" [
+ bench "critbit" $
+ whnf (C.isProperSubmapOfBy (<=) b_critbit_1) b_critbit
+ , bench "map" $
+ whnf (Map.isProperSubmapOfBy (<=) b_map_1) b_map
+ ]
+ , bgroup "findMin" [
+ bench "critbit" $ whnf C.findMin b_critbit
+ , bench "map" $ whnf Map.findMin b_map
+ ]
+ , bgroup "findMax" [
+ bench "critbit" $ whnf C.findMax b_critbit
+ , bench "map" $ whnf Map.findMax b_map
+ ]
+ , bgroup "deleteMin" [
+ bench "critbit" $ whnf C.deleteMin b_critbit
+ , bench "map" $ whnf Map.deleteMin b_map
+ ]
+ , bgroup "deleteMax" [
+ bench "critbit" $ whnf C.deleteMax b_critbit
+ , bench "map" $ whnf Map.deleteMax b_map
+ ]
+ , bgroup "deleteFindMin" [
+ bench "critbit" $ whnf (snd . C.deleteFindMin) b_critbit
+ , bench "map" $ whnf (snd . Map.deleteFindMin) b_map
+ ]
+ , bgroup "deleteFindMax" [
+ bench "critbit" $ whnf (snd . C.deleteFindMax) b_critbit
+ , bench "map" $ whnf (snd . Map.deleteFindMax) b_map
+ ]
+ , bgroup "minView" [
+ bench "critbit" $ whnf (snd . fromJust . C.minView) b_critbit
+ , bench "map" $ whnf (snd . fromJust . Map.minView) b_map
+ ]
+ , bgroup "maxView" [
+ bench "critbit" $ whnf (snd . fromJust . C.maxView) b_critbit
+ , bench "map" $ whnf (snd . fromJust . Map.maxView) b_map
+ ]
+ , bgroup "minViewWithKey" [
+ bench "critbit" $ whnf (snd . fromJust . C.minViewWithKey) b_critbit
+ , bench "map" $ whnf (snd . fromJust . Map.minViewWithKey) b_map
+ ]
+ , bgroup "maxViewWithKey" [
+ bench "critbit" $ whnf (snd . fromJust . C.minViewWithKey) b_critbit
+ , bench "map" $ whnf (snd . fromJust . Map.minViewWithKey) b_map
+ ]
+ , bgroup "updateMin" [
+ bench "critbit" $ whnf (C.updateMin updateFVal) b_critbit
+ , bench "map" $ whnf (Map.updateMin updateFVal) b_map
+ ]
+ , bgroup "updateMax" [
+ bench "critbit" $ whnf (C.updateMax updateFVal) b_critbit
+ , bench "map" $ whnf (Map.updateMax updateFVal) b_map
+ ]
+ , bgroup "traverseWithKey" $ let f _ = Identity . (+3) in [
+ bench "critbit" $ nf (runIdentity . C.traverseWithKey f) b_critbit
+#if MIN_VERSION_containers(0,5,0)
+ , bench "map" $ nf (runIdentity . Map.traverseWithKey f) b_map
+#endif
+ , bench "hashmap" $ nf (runIdentity . H.traverseWithKey f) b_hashmap
+ , bench "trie" $ nf (fmap f) b_trie
+ ]
+ , bgroup "updateMinWithKey" [
+ bench "critbit" $ whnf (C.updateMinWithKey updateFKey) b_critbit
+ , bench "map" $ whnf (Map.updateMinWithKey updateFKey) b_map
+ ]
+ , bgroup "updateMaxWithKey" [
+ bench "critbit" $ whnf (C.updateMaxWithKey updateFKey) b_critbit
+ , bench "map" $ whnf (Map.updateMaxWithKey updateFKey) b_map
+ ]
+ , bgroup "foldMap" [
+ bench "critbit" $ let c_foldmap :: (C.CritBitKey k, Num v)
+ => C.CritBit k v
+ -> Sum v
+ c_foldmap = foldMap Sum
+ in whnf c_foldmap b_critbit
+ , bench "map" $ let m_foldmap :: (Eq k, Num v)
+ => Map.Map k v
+ -> Sum v
+ m_foldmap = foldMap Sum
+ in whnf m_foldmap b_map
+ ]
+ , bgroup "alter" $ let altF (Just v) =
+ if odd v
+ then Just (v+1)
+ else Nothing
+ altF Nothing = Just 1
+ in [
+ bench "critbit" $ whnf (C.alter altF key) b_critbit
+ , bench "map" $ whnf (Map.alter altF key) b_map
+ ]
+ , bgroup "partitionWithKey" $ let predicate k _ = odd $ C.byteCount k in [
+ bench "critbit" $ whnf (forcePair . C.partitionWithKey predicate) b_critbit
+ , bench "map" $ whnf (forcePair . Map.partitionWithKey predicate) b_map
+ ]
+ , bgroup "partition" [
+ bench "critbit" $ whnf (forcePair . C.partition odd) b_critbit
+ , bench "map" $ whnf (forcePair . Map.partition odd) b_map
+ ]
+ ]
, bgroup "text" [
bgroup "fromList" [
bgroup "ordered" $ fromList t_ordKVs
, bgroup "random" $ fromList t_randKVs
, bgroup "reversed" $ fromList t_revKVs
+ ]
+ , bgroup "fromListWith" [
+ bgroup "ordered" $ fromListWith b_ordKVs
+ , bgroup "random" $ fromListWith b_randKVs
+ , bgroup "reversed" $ fromListWith b_revKVs
+ ]
+ , bgroup "fromListWithKey" [
+ bgroup "ordered" $ fromListWithKey b_ordKVs
+ , bgroup "random" $ fromListWithKey b_randKVs
+ , bgroup "reversed" $ fromListWithKey b_revKVs
]
]
]
diff --git a/critbit.cabal b/critbit.cabal
--- a/critbit.cabal
+++ b/critbit.cabal
@@ -1,18 +1,29 @@
name: critbit
-version: 0.0.0.0
+version: 0.1.0.0
homepage: https://github.com/bos/critbit
bug-reports: https://github.com/bos/critbit/issues
synopsis: Crit-bit maps and sets
description:
- Whee.
+ This package implements crit-bit trees, a key-value container type
+ for storing keys that can be treated as bitstrings (e.g.
+ 'ByteString' and 'Text').
+ .
+ Compared to the data structures from the containers and
+ unordered-containers packages, you will find that sometimes the
+ functions implemented in this package are faster, sometimes
+ slower.
+ .
+ In many cases, a 'CritBit' tree provides performance close to that
+ of a 'HashMap', while providing ordered storage and traversal
+ like a 'Map'.
license: BSD3
license-file: LICENSE
author: Bryan O'Sullivan
maintainer: Bryan O'Sullivan
-copyright: 2013 Bryan O'Sullivan
+copyright: 2013-2014 Bryan O'Sullivan and others
category: Data
build-type: Simple
-cabal-version: >= 1.8
+cabal-version: >= 1.14
extra-source-files:
README.markdown
@@ -21,18 +32,21 @@
default: False
library
+ default-language: Haskell2010
exposed-modules:
Data.CritBit.Map.Lazy
+ Data.CritBit.Set
other-modules:
Data.CritBit.Core
Data.CritBit.Types.Internal
Data.CritBit.Tree
build-depends:
+ array,
base >= 4 && < 5,
bytestring >= 0.9,
deepseq,
- text >= 0.11.3.1,
+ text >= 0.11.2.3,
vector
ghc-options: -Wall -funbox-strict-fields -O2 -fwarn-tabs
@@ -42,26 +56,33 @@
cpp-options: -DASSERTS
test-suite tests
+ default-language: Haskell2010
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: Main.hs
if impl(ghc >= 7.4)
- other-modules: Properties
+ other-modules:
+ Properties.Common
+ Properties.Map
+ Properties.Set
ghc-options:
- -Wall -threaded -rtsopts
+ -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends:
+ QuickCheck >= 2.7,
base >= 4 && < 5,
bytestring,
containers,
critbit,
- QuickCheck >= 2.4,
test-framework >= 0.4,
test-framework-quickcheck2 >= 0.2,
- text
+ text,
+ transformers >= 0.3,
+ vector
benchmark benchmarks
+ default-language: Haskell2010
type: exitcode-stdio-1.0
hs-source-dirs: benchmarks
main-is: Benchmarks.hs
@@ -79,6 +100,7 @@
mtl,
mwc-random,
text,
+ transformers >= 0.3,
unordered-containers,
vector
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -4,7 +4,12 @@
import Test.Framework
#if MIN_VERSION_base(4,5,0)
-import Properties (properties)
+import qualified Properties.Map as Map
+import qualified Properties.Set as Set
+
+properties :: [Test]
+properties = [ testGroup "map" Map.properties,
+ testGroup "set" Set.properties ]
#else
import Test.Framework.Providers.QuickCheck2 (testProperty)
diff --git a/tests/Properties.hs b/tests/Properties.hs
deleted file mode 100644
--- a/tests/Properties.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# 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 }
diff --git a/tests/Properties/Common.hs b/tests/Properties/Common.hs
new file mode 100644
--- /dev/null
+++ b/tests/Properties/Common.hs
@@ -0,0 +1,178 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, IncoherentInstances #-}
+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Properties.Common
+ (
+ Small(..)
+ , qc
+ , Props
+ , Eq'(..)
+ , SameAs(..)
+ , (=?=)
+ , (=??=)
+ , (=*=)
+ , (=?*=)
+ , (=??*=)
+ , (=**=)
+ , (=*==)
+ , notEmpty
+ , prepends
+ , kf
+ ) where
+
+import Control.Applicative ((<$>))
+import qualified Data.ByteString.Char8 as B
+import Data.CritBit.Map.Lazy (CritBitKey, byteCount)
+import Data.Monoid (Monoid, mappend)
+import Data.String (IsString, fromString)
+import qualified Data.Text as T
+import qualified Data.Vector.Generic as G
+import qualified Data.Vector.Unboxed as U
+import Data.Word
+import Test.Framework (Test)
+import Test.QuickCheck (Arbitrary(..), Args(..), quickCheckWith, stdArgs)
+import Test.QuickCheck.Gen (Gen, resize, sized)
+import Test.QuickCheck.Property (Property, Testable, (===), (.&&.), (.||.))
+
+instance IsString (U.Vector Word8) where
+ fromString = fromStringV
+
+instance IsString (U.Vector Word16) where
+ fromString = fromStringV
+
+instance IsString (U.Vector Word32) where
+ fromString = fromStringV
+
+instance IsString (U.Vector Word64) where
+ fromString = fromStringV
+
+instance IsString (U.Vector Word) where
+ fromString = fromStringV
+
+instance IsString (U.Vector Char) where
+ fromString = G.fromList
+
+fromStringV :: (G.Vector v a, Integral a) => String -> v a
+fromStringV = G.fromList . map (fromIntegral . fromEnum)
+
+instance Arbitrary B.ByteString where
+ arbitrary = B.pack <$> arbitrary
+ shrink = map B.pack . shrink . B.unpack
+
+instance Arbitrary T.Text where
+ arbitrary = T.pack <$> arbitrary
+ shrink = map T.pack . shrink . T.unpack
+
+instance Arbitrary (U.Vector Word8) where
+ arbitrary = arbitraryV
+ shrink = shrinkV
+
+instance Arbitrary (U.Vector Word16) where
+ arbitrary = arbitraryV
+ shrink = shrinkV
+
+instance Arbitrary (U.Vector Word32) where
+ arbitrary = arbitraryV
+ shrink = shrinkV
+
+instance Arbitrary (U.Vector Word64) where
+ arbitrary = arbitraryV
+ shrink = shrinkV
+
+instance Arbitrary (U.Vector Word) where
+ arbitrary = arbitraryV
+ shrink = shrinkV
+
+instance Arbitrary (U.Vector Char) where
+ arbitrary = arbitraryV
+ shrink = shrinkV
+
+arbitraryV :: (G.Vector v a, Arbitrary a) => Gen (v a)
+arbitraryV = G.fromList <$> arbitrary
+
+shrinkV :: (G.Vector v a, Arbitrary a) => v a -> [v a]
+shrinkV = map G.fromList . shrink . G.toList
+
+newtype Small a = Small { fromSmall :: a }
+ deriving (Eq, Ord, Show)
+
+instance (Show a, Arbitrary a) => Arbitrary (Small a) where
+ arbitrary = Small <$> (sized $ \n -> resize (smallish n) arbitrary)
+ where
+ smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
+ shrink = map Small . shrink . fromSmall
+
+type Props k = (Arbitrary k, CritBitKey k, Ord k, IsString k, Monoid k, Show k) => k -> [Test]
+
+infix 4 =^=, =?=, =??=
+
+-- | Compares heterogeneous values
+class (Show f, Show g) => Eq' f g where
+ (=^=) :: f -> g -> Property
+
+instance (Show t, Eq t) => Eq' t t where
+ (=^=) = (===)
+
+instance (Eq' a1 b1, Eq' a2 b2, Eq' a3 b3) => Eq' (a1, a2, a3) (b1, b2, b3)
+ where (a1, a2, a3) =^= (b1, b2, b3) = a1 =^= b1 .&&. a2 =^= b2 .&&. a3 =^= b3
+
+-- | Compares functions taking one scalar
+(=?=) :: Eq' a b => (t -> a) -> (t -> b) -> k -> t -> Property
+f =?= g = const $ \t -> f t =^= g t
+
+-- | Compares functions taking two scalars
+(=??=) :: Eq' a b => (t -> s -> a) -> (t -> s -> b) -> k -> t -> s -> Property
+f =??= g = const $ \t s -> f t s =^= g t s
+
+infix 4 =*=, =?*=, =*==
+
+-- | Types 'f' and 'g' have same behavior and common represenation 'r'.
+data SameAs f g r = SameAs {
+ toF :: r -> f
+ , fromF :: f -> r
+ , toG :: r -> g
+ , fromG :: g -> r
+ }
+
+-- | Compares two functions taking one container
+(=*=) :: (Eq' a b) => (f -> a) -> (g -> b)
+ -> SameAs f g r -> r -> Property
+(f =*= g) sa i = f (toF sa i) =^= g (toG sa i)
+
+-- | Compares two functions taking one scalar and one container
+(=?*=) :: (Eq' a b) => (t -> f -> a) -> (t -> g -> b)
+ -> SameAs f g r -> r -> t -> Property
+(f =?*= g) sa i t = (f t =*= g t) sa i
+
+-- | Compares functions taking two scalars and one container
+(=??*=) :: (Eq' a b) => (t -> s -> f -> a) -> (t -> s -> g -> b)
+ -> SameAs f g r -> r -> t -> s -> Property
+(f =??*= g) sa i t s = (f t s =*= g t s) sa i
+
+-- | Compares two functions taking two containers
+(=**=) :: (Eq' a b) => (f -> f -> a) -> (g -> g -> b)
+ -> SameAs f g r -> r -> r -> Property
+(f =**= g) sa i = (f (toF sa i) =*= g (toG sa i)) sa
+
+-- | Compares two functions taking one container with preprocessing
+(=*==) :: (Eq' f g) => (z -> f) -> (z -> g) -> (p -> z)
+ -> SameAs f g r -> p -> Property
+(f =*== g) p _ i = f i' =^= g i'
+ where i' = p i
+
+-- | Input litst is non-empty
+notEmpty :: (SameAs c1 c2 [i] -> [i] -> Property)
+ -> SameAs c1 c2 [i] -> [i] -> Property
+notEmpty f t items = null items .||. f t items
+
+prepends :: (IsString k, Monoid k) => k -> k
+prepends = mappend "test"
+
+-- | Keys mapping function
+kf :: (CritBitKey k, IsString k, Monoid k) => k -> k
+kf k = fromString (show (byteCount k)) `mappend` k
+
+-- Handy functions for fiddling with from ghci.
+
+qc :: Testable prop => Int -> prop -> IO ()
+qc n = quickCheckWith stdArgs { maxSuccess = n }
diff --git a/tests/Properties/Map.hs b/tests/Properties/Map.hs
new file mode 100644
--- /dev/null
+++ b/tests/Properties/Map.hs
@@ -0,0 +1,353 @@
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Properties.Map
+ where
+
+import qualified Data.ByteString.Char8 as B
+import Data.CritBit.Map.Lazy (CritBitKey, CritBit, byteCount)
+import qualified Data.CritBit.Map.Lazy as C
+import qualified Data.CritBit.Set as CSet
+import Data.Foldable (foldMap)
+import Data.Function (on)
+import Data.List (unfoldr, sort, nubBy)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Monoid (Sum(..))
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Vector.Generic as G
+import qualified Data.Vector.Unboxed as U
+import Data.Word
+import Properties.Common
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.QuickCheck.Property ((.&&.))
+
+--only needed for a test requiring containers >= 0.5
+#if MIN_VERSION_containers(0,5,0)
+import Data.Functor.Identity (Identity(..))
+#endif
+
+type V = Word8
+
+-- * Common modifier functions
+
+kvvf :: (CritBitKey k) => k -> V -> V -> V
+kvvf k v1 v2 = fromIntegral (byteCount k) * 3 + v1 * 2 - v2
+
+kvvfm :: (CritBitKey k) => k -> V -> V -> Maybe V
+kvvfm k v1 v2 = if even v1 then Just (kvvf k v1 v2) else Nothing
+
+kvf :: (CritBitKey k) => k -> V -> V
+kvf k v = kvvf k v 0
+
+kvfm :: (CritBitKey k) => k -> V -> Maybe V
+kvfm k v = kvvfm k v 0
+
+vvfm :: V -> V -> Maybe V
+vvfm = kvvfm ("" :: T.Text)
+
+vfm :: V -> Maybe V
+vfm = kvfm ("" :: T.Text)
+
+propertiesFor :: Props k
+propertiesFor w = concat [[]
+ -- ** Lists
+ , prop sa "t_fromList" $
+ (C.fromList =*== Map.fromList) id
+ , prop sa "t_fromListWith" $
+ (C.fromListWith (-) =*== Map.fromListWith (-)) id
+ , prop sa "t_fromListWithKey" $
+ (C.fromListWithKey kvvf =*== Map.fromListWithKey kvvf) id
+
+ -- * Query
+ , prop sa "t_null" $
+ C.null =*= Map.null
+ , prop sa "t_size" $
+ C.size =*= Map.size
+ , prop sa "t_member" $
+ C.member =?*= Map.member
+ , prop sa "t_member" $
+ C.notMember =?*= Map.notMember
+ , prop sa "t_lookup" $
+ C.lookup =?*= Map.lookup
+ , prop sa "t_findWithDefault" $
+ C.findWithDefault =??*= Map.findWithDefault
+
+#if MIN_VERSION_containers(0,5,0)
+ , prop sa "t_lookupGT" $
+ C.lookupGT =?*= Map.lookupGT
+ , prop sa "t_lookupGE" $
+ C.lookupGE =?*= Map.lookupGE
+ , prop sa "t_lookupLT" $
+ C.lookupLT =?*= Map.lookupLT
+ , prop sa "t_lookupLE" $
+ C.lookupLE =?*= Map.lookupLE
+#endif
+
+ -- * Insertion
+ , pmprop sa "t_insert" $
+ C.insert =??*= Map.insert
+ , pmprop sa "t_insertWith" $
+ C.insertWith (-) =??*= Map.insertWith (-)
+ , pmprop sa "t_insertWithKey" $
+ C.insertWithKey kvvf =??*= Map.insertWithKey kvvf
+ , pmprop sa "t_insertLookupWithKey" $
+ C.insertLookupWithKey kvvf =??*= Map.insertLookupWithKey kvvf
+
+ -- * Deletion
+ , pmprop sa "t_delete" $
+ C.delete =?*= Map.delete
+ , pmprop sa "t_adjust" $
+ C.adjust (+3) =?*= Map.adjust (+3)
+ , pmprop sa "t_adjustWithKey" $
+ C.adjustWithKey kvf =?*= Map.adjustWithKey kvf
+ , pmprop sa "t_update" $
+ C.update vfm =?*= Map.update vfm
+ , pmprop sa "t_updateWithKey" $
+ C.updateWithKey kvfm =?*= Map.updateWithKey kvfm
+ , pmprop sa "t_updateLookupWithKey" $
+ C.updateLookupWithKey kvfm =?*= Map.updateLookupWithKey kvfm
+ , prop sa "t_alter" $
+ let f = Just . maybe 1 (+1)
+ in C.alter f =?*= Map.alter f
+ , prop sa "t_alter_delete" $
+ C.alter (const Nothing) =?*= Map.alter (const Nothing)
+
+ -- * Combination
+ -- ** Union
+ , prop sa "t_union" $
+ C.union =**= Map.union
+ , prop sa "t_unionWith" $
+ C.unionWith (-) =**= Map.unionWith (-)
+ , prop sa "t_unionWithKey" $
+ C.unionWithKey kvvf =**= Map.unionWithKey kvvf
+ , prop sa "t_unions" $
+ ( C.unions . map C.fromList =*==
+ Map.unions . map Map.fromList) fromSmall
+ , prop sa "t_unionsWith" $
+ ( C.unionsWith (-) . map C.fromList =*==
+ Map.unionsWith (-) . map Map.fromList) fromSmall
+ , prop sa "t_unionL" $
+ C.unionL =**= Map.union
+ , prop sa "t_unionR" $
+ C.unionR =**= flip Map.union
+
+ -- ** Difference
+ , prop sa "t_difference" $
+ C.difference =**= Map.difference
+ , prop sa "t_differenceWith" $
+ C.differenceWith vvfm =**= Map.differenceWith vvfm
+ , prop sa "t_differenceWithKey" $
+ C.differenceWithKey kvvfm =**= Map.differenceWithKey kvvfm
+
+ -- ** Intersection
+ , prop sa "t_intersection" $
+ C.intersection =**= Map.intersection
+ , prop sa "t_intersectionWith" $
+ C.intersectionWith (-) =**= Map.intersectionWith (-)
+ , prop sa "t_intersectionWithKey" $
+ C.intersectionWithKey kvvf =**= Map.intersectionWithKey kvvf
+
+ -- * Traversal
+ -- ** Map
+ , prop sa "t_map" $
+ C.map (+3) =*= Map.map (+3)
+ , prop sa "t_mapWithKey" $
+ C.mapWithKey kvf =*= Map.mapWithKey kvf
+#if MIN_VERSION_containers(0,5,0)
+ , prop sa "t_traverseWithKey" $
+ let f _ = Identity . show . (+3)
+ in runIdentity . C.traverseWithKey f =*= runIdentity . Map.traverseWithKey f
+#endif
+ , prop sa "t_mapAccum" $
+ let f i v = (i + 1 :: Int, show $ v + 3)
+ in C.mapAccum f 0 =*= Map.mapAccum f 0
+ , prop sa "t_mapAccumWithKey" $
+ let f i k v = (i + byteCount k, show $ v + 3)
+ in C.mapAccumWithKey f 0 =*= Map.mapAccumWithKey f 0
+ , prop sa "t_mapAccumRWithKey" $
+ let f i k v = (i + byteCount k, show $ v + 3)
+ in C.mapAccumRWithKey f 0 =*= Map.mapAccumRWithKey f 0
+ , prop sa "t_mapKeys" $
+ C.mapKeys kf =*= Map.mapKeys kf
+ , prop sa "t_mapKeysWith" $
+ C.mapKeysWith (+) kf =*= Map.mapKeysWith (+) kf
+ , prop sa "t_mapKeysMonotonic" $
+ C.mapKeysMonotonic prepends =*= Map.mapKeysMonotonic prepends
+
+ -- * Folds
+ , prop sa "t_foldl" $
+ C.foldl (-) 0 =*= Map.foldl (-) 0
+ , prop sa "t_foldlWithKey" $
+ let f i k v = i * 37 + (byteCount k) * 17 + fromIntegral v
+ in C.foldlWithKey f 0 =*= Map.foldlWithKey f 0
+ , prop sa "t_foldr" $
+ C.foldr (-) 0 =*= Map.foldr (-) 0
+ , prop sa "t_foldrWithKey" $
+ let f k v i = i * 37 + (byteCount k) * 17 + fromIntegral v
+ in C.foldrWithKey f 0 =*= Map.foldrWithKey f 0
+
+ -- ** Strict folds
+ , prop sa "t_foldl'" $
+ C.foldl' (-) 0 =*= Map.foldl' (-) 0
+ , prop sa "t_foldlWithKey'" $
+ let f i k v = i * 37 + (byteCount k) * 17 + fromIntegral v
+ in C.foldlWithKey' f 0 =*= Map.foldlWithKey' f 0
+ , prop sa "t_foldr'" $
+ C.foldr' (-) 0 =*= Map.foldr' (-) 0
+ , prop sa "t_foldrWithKey'" $
+ let f k v i = i * 37 + (byteCount k) * 17 + fromIntegral v
+ in C.foldrWithKey' f 0 =*= Map.foldrWithKey' f 0
+
+ -- * Conversion
+ , prop sa "t_elems" $
+ C.elems =*= Map.elems
+ , prop sa "t_keys" $
+ C.keys =*= Map.keys
+ , prop sa "assocs" $
+ C.assocs =*= Map.assocs
+ , prop sa "t_keysSet" $
+ CSet.toList . C.keysSet =*= Set.toList . Map.keysSet
+#if MIN_VERSION_containers(0,5,0)
+ , prop sa "t_fromSet" $
+ let f = length . show
+ in C.fromSet f . C.keysSet =*= Map.fromSet f . Map.keysSet
+#endif
+
+ -- ** Ordered lists
+ , prop sa "t_toAscList" $
+ C.toAscList =*= Map.toAscList
+ , prop sa "t_toDescList" $
+ C.toDescList =*= Map.toDescList
+ , prop sa "t_fromAscList" $
+ (C.fromAscList =*== Map.fromAscList) sort
+ , prop sa "t_fromAscListWith" $
+ (C.fromAscListWith (+) =*== Map.fromAscListWith (+)) sort
+ , prop sa "t_fromAscListWithKey" $
+ (C.fromAscListWithKey kvvf =*== Map.fromAscListWithKey kvvf) sort
+ , prop sa "t_fromDistinctAscList" $
+ let p = nubBy ((==) `on` fst) . sort
+ in (C.fromDistinctAscList =*== Map.fromDistinctAscList) p
+
+ -- * Filter
+ , prop sa "t_filter" $
+ C.filter odd =*= Map.filter odd
+ , prop sa "t_filterWithKey" $
+ let p k v = odd $ kvf k v
+ in C.filterWithKey p =*= Map.filterWithKey p
+ , prop sa "t_partition" $ C.partition odd =*= Map.partition odd
+ , prop sa "t_partitionWithKey" $
+ let p k v = odd $ kvf k v
+ in C.partitionWithKey p =*= Map.partitionWithKey p
+
+ , prop sa "t_mapMaybe" $
+ C.mapMaybe vfm =*= Map.mapMaybe vfm
+ , prop sa "t_mapMaybeWithKey" $
+ C.mapMaybeWithKey kvfm =*= Map.mapMaybeWithKey kvfm
+ , prop sa "t_mapEither" $
+ let f v = if even v then Left (2 * v) else Right (3 * v)
+ in C.mapEither f =*= Map.mapEither f
+ , prop sa "t_mapEitherWithKey" $
+ let f k v = if even v then Left (kvf k v) else Right (3 * v)
+ in C.mapEitherWithKey f =*= Map.mapEitherWithKey f
+
+ , pmprop sa "t_split" $
+ C.split =?*= Map.split
+ , pmprop sa "t_splitLookup" $
+ C.splitLookup =?*= Map.splitLookup
+
+ -- * Submap
+ , prop sa "t_isSubmapOf" $
+ C.isSubmapOf =**= Map.isSubmapOf
+ , prop sa "t_isSubmapOfBy" $
+ C.isSubmapOfBy (<=) =**= Map.isSubmapOfBy (<=)
+ , prop sa "t_isProperSubmapOf" $
+ C.isProperSubmapOf =**= Map.isProperSubmapOf
+ , prop sa "t_isProperSubmapOfBy" $
+ C.isProperSubmapOfBy (<=) =**= Map.isProperSubmapOfBy (<=)
+
+ -- * Min\/Max
+ , prop sa "t_findMin" $ notEmpty $
+ C.findMin =*= Map.findMin
+ , prop sa "t_findMax" $ notEmpty $
+ C.findMax =*= Map.findMax
+ , prop sa "t_deleteMin" $ notEmpty $
+ C.deleteMin =*= Map.deleteMin
+ , prop sa "t_deleteMax" $ notEmpty $
+ C.deleteMax =*= Map.deleteMax
+ , prop sa "t_deleteFindMin" $ notEmpty $
+ C.deleteFindMin =*= Map.deleteFindMin
+ , prop sa "t_deleteFindMax" $ notEmpty $
+ C.deleteFindMax =*= Map.deleteFindMax
+ , prop sa "t_updateMin" $
+ C.updateMinWithKey kvfm =*= Map.updateMinWithKey kvfm
+ , prop sa "t_updateMax" $
+ C.updateMaxWithKey kvfm =*= Map.updateMaxWithKey kvfm
+ , prop sa "t_updateMinWithKey" $
+ C.updateMinWithKey kvfm =*= Map.updateMinWithKey kvfm
+ , prop sa "t_updateMaxWithKey" $
+ C.updateMaxWithKey kvfm =*= Map.updateMaxWithKey kvfm
+ , prop sa "t_minView" $
+ unfoldr C.minView =*= unfoldr Map.minView
+ , prop sa "t_maxView" $
+ unfoldr C.maxView =*= unfoldr Map.maxView
+ , prop sa "t_minViewWithKey" $
+ unfoldr C.minViewWithKey =*= unfoldr Map.minViewWithKey
+ , prop sa "t_maxViewWithKey" $
+ unfoldr C.maxViewWithKey =*= unfoldr Map.maxViewWithKey
+
+ , prop sa "t_foldMap" $
+ foldMap Sum =*= foldMap Sum
+ ]
+ where
+ prop sa' name q = [testProperty name $ q sa']
+ pmprop sa' name t = [
+ testProperty (name ++ "_general") $ general
+ , testProperty (name ++ "_present") $ present
+ , testProperty (name ++ "_missing") $ missing
+ ]
+ where
+ general k kvs = t sa' kvs k
+ present k v kvs = t sa' ((k, v):kvs) k
+ missing k kvs = t sa' (filter ((/= k) . fst) kvs) k
+
+ sa = sameAs w
+
+ sameAs :: (CritBitKey k, Ord k)
+ => k -> SameAs (CritBit k V) (Map k V) [(k, V)]
+ sameAs _ = SameAs C.fromList C.toList Map.fromList Map.toList
+
+properties :: [Test]
+properties = [
+ testGroup "text" $ propertiesFor T.empty
+ , testGroup "bytestring" $ propertiesFor B.empty
+ , testGroup "vector" [
+ testGroup "unboxed" [
+ testGroup "Word8" $ propertiesFor (G.empty :: U.Vector Word8)
+ , testGroup "Word16" $ propertiesFor (G.empty :: U.Vector Word16)
+ , testGroup "Word32" $ propertiesFor (G.empty :: U.Vector Word32)
+ , testGroup "Word64" $ propertiesFor (G.empty :: U.Vector Word64)
+ , testGroup "Word" $ propertiesFor (G.empty :: U.Vector Word)
+ , testGroup "Char" $ propertiesFor (G.empty :: U.Vector Char)
+ ]
+ ]
+ ]
+
+instance (Eq k, Show k, Eq v, Show v) => Eq' (CritBit k v) (Map k v) where
+ c =^= m = C.toList c =^= Map.toList m
+
+instance (Eq' a1 b1, Eq k, Show k, Eq v, Show v) => Eq' (a1, CritBit k v) (b1, Map k v) where
+ (a1, a2) =^= (b1, b2) = a1 =^= b1 .&&. a2 =^= b2
+
+-- Handy functions for fiddling with from ghci.
+
+blist :: [B.ByteString] -> CritBit B.ByteString Word8
+blist = C.fromList . flip zip [0..]
+
+tlist :: [T.Text] -> CritBit T.Text Word8
+tlist = C.fromList . flip zip [0..]
+
+mlist :: [B.ByteString] -> Map B.ByteString Word8
+mlist = Map.fromList . flip zip [0..]
diff --git a/tests/Properties/Set.hs b/tests/Properties/Set.hs
new file mode 100644
--- /dev/null
+++ b/tests/Properties/Set.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Properties.Set
+ where
+
+import qualified Data.ByteString.Char8 as B
+import Data.CritBit.Map.Lazy (CritBitKey, byteCount)
+import qualified Data.CritBit.Set as C
+import Data.List (unfoldr, sort, nub)
+import qualified Data.Set as S
+import qualified Data.Text as T
+import Properties.Common
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.QuickCheck.Property ((.&&.))
+
+kp :: (CritBitKey k) => k -> Bool
+kp = even . byteCount
+
+kii :: (CritBitKey k, Show k) => k -> Int -> Int
+kii k v = byteCount k * 13 + v
+
+propertiesFor :: Props k
+propertiesFor t = concat [[]
+ -- * Operators
+ , prop "t_diff" $ (C.\\) =**= (S.\\)
+
+ -- * Query
+ , prop "t_null" $ C.null =*= S.null
+ , prop "t_size" $ C.size =*= S.size
+ , prop "t_member" $ C.member =?*= S.member
+ , prop "t_notMember" $ C.notMember =?*= S.notMember
+#if MIN_VERSION_containers(0,5,0)
+ , prop "t_lookupLT" $ C.lookupLT =?*= S.lookupLT
+ , prop "t_lookupGT" $ C.lookupGT =?*= S.lookupGT
+ , prop "t_lookupLE" $ C.lookupLE =?*= S.lookupLE
+ , prop "t_lookupGE" $ C.lookupGE =?*= S.lookupGE
+#endif
+ , prop "t_isSubsetOf" $ C.isSubsetOf =**= S.isSubsetOf
+ , prop "t_isProperSubsetOf" $ C.isProperSubsetOf =**= S.isProperSubsetOf
+
+ -- * Construction
+-- , prop "t_empty" $ C.empty =^= S.empty
+ , prop "t_singleton" $ notEmpty $ (C.singleton =*== S.singleton) head
+ , prop "t_insert" $ C.insert =?*= S.insert
+ , prop "t_delete" $ C.delete =?*= S.delete
+
+ -- * Combine
+ , prop "t_union" $ C.union =**= S.union
+ , prop "t_unions" $ (C.unions . map C.fromList =*==
+ S.unions . map S.fromList) fromSmall
+ , prop "t_difference" $ C.difference =**= S.difference
+ , prop "t_intersection" $ C.intersection =**= S.intersection
+
+ -- * Filter
+ , prop "t_filter" $ C.filter kp =*= S.filter kp
+ , prop "t_partition" $ C.partition kp =*= S.partition kp
+ , prop "t_split" $ C.split =?*= S.split
+ , prop "t_splitMember" $ C.splitMember =?*= S.splitMember
+
+ -- * Map
+ , prop "t_map" $ C.map kf =*= S.map kf
+ , prop "t_mapMonotonic" $ C.mapMonotonic prepends =*= S.mapMonotonic prepends
+
+ -- * Folds
+ , prop "t_foldr" $ C.foldr kii 0 =*= S.foldr kii 0
+ , prop "t_foldl" $ C.foldl (flip kii) 0 =*= S.foldl (flip kii) 0
+ -- ** Strict folds
+ , prop "t_foldr'" $ C.foldr' kii 0 =*= S.foldr' kii 0
+ , prop "t_foldl'" $ C.foldl' (flip kii) 0 =*= S.foldl' (flip kii) 0
+
+ -- * Min\/Max
+ , prop "t_findMin" $ notEmpty $ C.findMin =*= S.findMin
+ , prop "t_findMax" $ notEmpty $ C.findMax =*= S.findMax
+ , prop "t_deleteMin" $ notEmpty $ C.deleteMin =*= S.deleteMin
+ , prop "t_deleteMax" $ notEmpty $ C.deleteMax =*= S.deleteMax
+ , prop "t_deleteFindMin" $ notEmpty $ C.deleteFindMin =*= S.deleteFindMin
+ , prop "t_deleteFindMax" $ notEmpty $ C.deleteFindMax =*= S.deleteFindMax
+ , prop "t_maxView" $ notEmpty $ unfoldr C.maxView =*= unfoldr S.maxView
+ , prop "t_minView" $ notEmpty $ unfoldr C.minView =*= unfoldr S.minView
+
+ -- * Conversion
+ -- ** List
+ , prop "t_elems" $ C.elems =*= S.elems
+ , prop "t_toList" $ C.toList =*= S.toList
+ , prop "t_fromList" $ (C.fromList =*== S.fromList) id
+
+ -- ** Ordered list
+ , prop "t_toAscList" $ C.toAscList =*= S.toAscList
+#if MIN_VERSION_containers(0,5,0)
+ , prop "t_toDescList" $ C.toDescList =*= S.toDescList
+#endif
+ , prop "t_fromAscList" $ (C.fromAscList =*== S.fromAscList) sort
+ , prop "t_fromDistinctAscList" $
+ (C.fromDistinctAscList =*== S.fromDistinctAscList) (nub . sort)
+ ]
+ where
+ prop name q = [testProperty name $ q $ sameAs t]
+
+ sameAs :: (CritBitKey k, Ord k) => k -> SameAs (C.Set k) (S.Set k) [k]
+ sameAs _ = SameAs C.fromList C.toList S.fromList S.toList
+
+properties :: [Test]
+properties = [
+ testGroup "text" $ propertiesFor T.empty
+ , testGroup "bytestring" $ propertiesFor B.empty
+ ]
+
+instance (Show k, Eq k) => Eq' (C.Set k) (S.Set k) where
+ c =^= m = C.toList c =^= S.toList m
+
+instance (Eq' a1 b1, Eq k, Show k) => Eq' (a1, C.Set k) (b1, S.Set k) where
+ (a1, a2) =^= (b1, b2) = a1 =^= b1 .&&. a2 =^= b2
+
+-- Handy functions for fiddling with from ghci.
+
+blist :: [B.ByteString] -> C.Set B.ByteString
+blist = C.fromList
+
+tlist :: [T.Text] -> S.Set T.Text
+tlist = S.fromList