critbit 0.0.0.0 → 0.1.0.0

raw patch · 12 files changed

+3586/−716 lines, 12 filesdep +arraydep +transformersdep ~QuickCheckdep ~basedep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: array, transformers

Dependency ranges changed: QuickCheck, base, text

API changes (from Hackage documentation)

Files

• Data/CritBit/Core.hs +226/−80
• Data/CritBit/Set.hs +456/−0
• Data/CritBit/Tree.hs +1519/−420
• Data/CritBit/Types/Internal.hs +180/−8
• README.markdown +53/−42
• benchmarks/Benchmarks.hs +463/−19
• critbit.cabal +31/−9
• tests/Main.hs +6/−1
• tests/Properties.hs +0/−137
• tests/Properties/Common.hs +178/−0
• tests/Properties/Map.hs +353/−0
• tests/Properties/Set.hs +121/−0

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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)

@@ -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.++* <b>Do not add trailing whitespace</b>. 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.)

@@ -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         ]       ]     ]

@@ -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 <bos@serpentine.com> maintainer:     Bryan O'Sullivan <bos@serpentine.com>-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 

@@ -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) 

@@ -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 }

@@ -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 }

@@ -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..]

@@ -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