diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for strict-containers +## 0.2.1 -- 2024-08-05 + +- Update to containers v0.6.7, unordered-containers v0.2.20, vector + v0.13.1.0. Includes support for GHC 9.10. + ## 0.2 -- 2022-12-12 - Update to containers v0.6.6, unordered-containers v0.2.19.1, vector diff --git a/src/Data/Strict/ContainersUtils/Autogen/Prelude.hs b/src/Data/Strict/ContainersUtils/Autogen/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/ContainersUtils/Autogen/Prelude.hs @@ -0,0 +1,12 @@ +-- | This hideous module lets us avoid dealing with the fact that +-- @liftA2@ and @foldl'@ were not previously exported from the standard prelude. +module Data.Strict.ContainersUtils.Autogen.Prelude + ( module Prelude + , Applicative (..) + , Foldable (..) + ) + where + +import Prelude hiding (Applicative(..), Foldable(..)) +import Control.Applicative(Applicative(..)) +import Data.Foldable (Foldable(elem, foldMap, foldr, foldl, foldl', foldr1, foldl1, maximum, minimum, product, sum, null, length)) diff --git a/src/Data/Strict/ContainersUtils/Autogen/State.hs b/src/Data/Strict/ContainersUtils/Autogen/State.hs --- a/src/Data/Strict/ContainersUtils/Autogen/State.hs +++ b/src/Data/Strict/ContainersUtils/Autogen/State.hs @@ -6,7 +6,9 @@ module Data.Strict.ContainersUtils.Autogen.State where import Control.Monad (ap, liftM2) -import Control.Applicative (Applicative(..), liftA) +import Control.Applicative (liftA) +import Data.Strict.ContainersUtils.Autogen.Prelude +import Prelude () newtype State s a = State {runState :: s -> (s, a)} @@ -26,9 +28,7 @@ (<*>) = ap m *> n = State $ \s -> case runState m s of (s', _) -> runState n s' -#if MIN_VERSION_base(4,10,0) liftA2 = liftM2 -#endif execState :: State s a -> s -> a execState m x = snd (runState m x) diff --git a/src/Data/Strict/HashMap/Autogen/Internal.hs b/src/Data/Strict/HashMap/Autogen/Internal.hs --- a/src/Data/Strict/HashMap/Autogen/Internal.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal.hs @@ -107,16 +107,21 @@ , fromListWith , fromListWithKey - -- Internals used by the strict version + -- ** Internals used by the strict version , Hash , Bitmap + , Shift , bitmapIndexedOrFull , collision , hash , mask , index , bitsPerSubkey - , fullNodeMask + , maxChildren + , isLeafOrCollision + , fullBitmap + , subkeyMask + , nextShift , sparseIndex , two , unionArrayBy @@ -129,6 +134,7 @@ , equalKeys1 , lookupRecordCollision , LookupRes(..) + , lookupResToMaybe , insert' , delete' , lookup' @@ -158,8 +164,8 @@ import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) import GHC.Exts (Int (..), Int#, TYPE, (==#)) import GHC.Stack (HasCallStack) -import Prelude hiding (filter, foldl, foldr, lookup, map, - null, pred) +import Prelude hiding (Foldable(..), filter, lookup, map, + pred) import Text.Read hiding (step) import qualified Data.Data as Data @@ -172,9 +178,6 @@ import qualified GHC.Exts as Exts import qualified Language.Haskell.TH.Syntax as TH --- | A set of values. A set cannot contain duplicate values. ------------------------------------------------------------------------- - -- | Convenience function. Compute a hash value for the given value. hash :: H.Hashable a => a -> Hash hash = fromIntegral . H.hash @@ -201,17 +204,46 @@ instance NFData2 Leaf where liftRnf2 rnf1 rnf2 (L k v) = rnf1 k `seq` rnf2 v --- Invariant: The length of the 1st argument to 'Full' is --- 2^bitsPerSubkey - -- | A map from keys to values. A map cannot contain duplicate keys; -- each key can map to at most one value. data HashMap k v = Empty + -- ^ Invariants: + -- + -- * 'Empty' is not a valid sub-node. It can only appear at the root. (INV1) | BitmapIndexed !Bitmap !(A.Array (HashMap k v)) + -- ^ Invariants: + -- + -- * Only the lower @maxChildren@ bits of the 'Bitmap' may be set. The + -- remaining upper bits must be 0. (INV2) + -- * The array of a 'BitmapIndexed' node stores at least 1 and at most + -- @'maxChildren' - 1@ sub-nodes. (INV3) + -- * The number of sub-nodes is equal to the number of 1-bits in its + -- 'Bitmap'. (INV4) + -- * If a 'BitmapIndexed' node has only one sub-node, this sub-node must + -- be a 'BitmapIndexed' or a 'Full' node. (INV5) | Leaf !Hash !(Leaf k v) + -- ^ Invariants: + -- + -- * The location of a 'Leaf' or 'Collision' node in the tree must be + -- compatible with its 'Hash'. (INV6) + -- (TODO: Document this properly (#425)) + -- * The 'Hash' of a 'Leaf' node must be the 'hash' of its key. (INV7) | Full !(A.Array (HashMap k v)) + -- ^ Invariants: + -- + -- * The array of a 'Full' node stores exactly 'maxChildren' sub-nodes. (INV8) | Collision !Hash !(A.Array (Leaf k v)) + -- ^ Invariants: + -- + -- * The location of a 'Leaf' or 'Collision' node in the tree must be + -- compatible with its 'Hash'. (INV6) + -- (TODO: Document this properly (#425)) + -- * The array of a 'Collision' node must contain at least two sub-nodes. (INV9) + -- * The 'hash' of each key in a 'Collision' node must be the one stored in + -- the node. (INV7) + -- * No two keys stored in a 'Collision' can be equal according to their + -- 'Eq' instance. (INV10) type role HashMap nominal representational @@ -314,7 +346,7 @@ -- | This type is used to store the hash of a key, as produced with 'hash'. type Hash = Word --- | A bitmap as contained by a 'BitmapIndexed' node, or a 'fullNodeMask' +-- | A bitmap as contained by a 'BitmapIndexed' node, or a 'fullBitmap' -- corresponding to a 'Full' node. -- -- Only the lower 'maxChildren' bits are used. The remaining bits must be zeros. @@ -366,7 +398,7 @@ liftEq = equal1 -- | Note that, in the presence of hash collisions, equal @HashMap@s may --- behave differently, i.e. substitutivity may be violated: +-- behave differently, i.e. extensionality may be violated: -- -- >>> data D = A | B deriving (Eq, Show) -- >>> instance Hashable D where hashWithSalt salt _d = salt @@ -381,14 +413,11 @@ -- >>> toList y -- [(B,2),(A,1)] -- --- In general, the lack of substitutivity can be observed with any function +-- In general, the lack of extensionality can be observed with any function -- that depends on the key ordering, such as folds and traversals. instance (Eq k, Eq v) => Eq (HashMap k v) where (==) = equal1 (==) --- We rely on there being no Empty constructors in the tree! --- This ensures that two equal HashMaps will have the same --- shape, modulo the order of entries in Collisions. equal1 :: Eq k => (v -> v' -> Bool) -> HashMap k v -> HashMap k v' -> Bool @@ -417,8 +446,8 @@ | k1 == k2 && leafEq l1 l2 = go tl1 tl2 - go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) - | k1 == k2 && + go (Collision h1 ary1 : tl1) (Collision h2 ary2 : tl2) + | h1 == h2 && A.length ary1 == A.length ary2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2) = go tl1 tl2 @@ -447,8 +476,8 @@ = compare k1 k2 `mappend` leafCompare l1 l2 `mappend` go tl1 tl2 - go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) - = compare k1 k2 `mappend` + go (Collision h1 ary1 : tl1) (Collision h2 ary2 : tl2) + = compare h1 h2 `mappend` compare (A.length ary1) (A.length ary2) `mappend` unorderedCompare leafCompare (A.toList ary1) (A.toList ary2) `mappend` go tl1 tl2 @@ -468,8 +497,8 @@ go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) | k1 == k2 && leafEq l1 l2 = go tl1 tl2 - go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) - | k1 == k2 && A.length ary1 == A.length ary2 && + go (Collision h1 ary1 : tl1) (Collision h2 ary2 : tl2) + | h1 == h2 && A.length ary1 == A.length ary2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2) = go tl1 tl2 go [] [] = True @@ -623,10 +652,15 @@ (# | (# a, _i #) #) -> Just a {-# INLINE lookup' #-} --- The result of a lookup, keeping track of if a hash collision occured. +-- The result of a lookup, keeping track of if a hash collision occurred. -- If a collision did not occur then it will have the Int value (-1). data LookupRes a = Absent | Present a !Int +lookupResToMaybe :: LookupRes a -> Maybe a +lookupResToMaybe Absent = Nothing +lookupResToMaybe (Present x _) = Just x +{-# INLINE lookupResToMaybe #-} + -- Internal helper for lookup. This version takes the precomputed hash so -- that functions that make multiple calls to lookup and related functions -- (insert, delete) only need to calculate the hash once. @@ -688,10 +722,10 @@ go h k s (BitmapIndexed b v) | b .&. m == 0 = absent (# #) | otherwise = - go h k (s+bitsPerSubkey) (A.index v (sparseIndex b m)) + go h k (nextShift s) (A.index v (sparseIndex b m)) where m = mask h s go h k s (Full v) = - go h k (s+bitsPerSubkey) (A.index v (index h s)) + go h k (nextShift s) (A.index v (index h s)) go h k _ (Collision hx v) | h == hx = lookupInArrayCont absent present k v | otherwise = absent (# #) @@ -757,7 +791,7 @@ -- @unionWith[Key]@ with GHC 9.2.2. See the Core diffs in -- https://github.com/haskell-unordered-containers/unordered-containers/pull/376. bitmapIndexedOrFull b !ary - | b == fullNodeMask = Full ary + | b == fullBitmap = Full ary | otherwise = BitmapIndexed b ary {-# INLINE bitmapIndexedOrFull #-} @@ -785,7 +819,7 @@ in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) st + !st' = go h k x (nextShift s) st in if st' `ptrEq` st then t else BitmapIndexed b (A.update ary i st') @@ -793,7 +827,7 @@ i = sparseIndex b m go h k x s t@(Full ary) = let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) st + !st' = go h k x (nextShift s) st in if st' `ptrEq` st then t else Full (update32 ary i st') @@ -823,13 +857,13 @@ in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) st + !st' = go h k x (nextShift s) st in BitmapIndexed b (A.update ary i st') where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) st + !st' = go h k x (nextShift s) st in Full (update32 ary i st') where i = index h s go h k x s t@(Collision hy v) @@ -843,36 +877,42 @@ -- -- It is only valid to call this when the key exists in the map and you know the -- hash collision position if there was one. This information can be obtained --- from 'lookupRecordCollision'. If there is no collision pass (-1) as collPos +-- from 'lookupRecordCollision'. If there is no collision, pass (-1) as collPos -- (first argument). --- --- We can skip the key equality check on a Leaf because we know the leaf must be --- for this key. insertKeyExists :: Int -> Hash -> k -> v -> HashMap k v -> HashMap k v -insertKeyExists !collPos0 !h0 !k0 x0 !m0 = go collPos0 h0 k0 x0 0 m0 +insertKeyExists !collPos0 !h0 !k0 x0 !m0 = go collPos0 h0 k0 x0 m0 where - go !_collPos !h !k x !_s (Leaf _hy _kx) + go !_collPos !_shiftedHash !k x (Leaf h _kx) = Leaf h (L k x) - go collPos h k x s (BitmapIndexed b ary) - | b .&. m == 0 = - let !ary' = A.insert ary i $ Leaf h (L k x) - in bitmapIndexedOrFull (b .|. m) ary' - | otherwise = - let !st = A.index ary i - !st' = go collPos h k x (s+bitsPerSubkey) st - in BitmapIndexed b (A.update ary i st') - where m = mask h s + go collPos shiftedHash k x (BitmapIndexed b ary) = + let !st = A.index ary i + !st' = go collPos (shiftHash shiftedHash) k x st + in BitmapIndexed b (A.update ary i st') + where m = mask' shiftedHash i = sparseIndex b m - go collPos h k x s (Full ary) = + go collPos shiftedHash k x (Full ary) = let !st = A.index ary i - !st' = go collPos h k x (s+bitsPerSubkey) st + !st' = go collPos (shiftHash shiftedHash) k x st in Full (update32 ary i st') - where i = index h s - go collPos h k x _s (Collision _hy v) + where i = index' shiftedHash + go collPos _shiftedHash k x (Collision h v) | collPos >= 0 = Collision h (setAtPosition collPos k x v) | otherwise = Empty -- error "Internal error: go {collPos negative}" - go _ _ _ _ _ Empty = Empty -- error "Internal error: go Empty" + go _ _ _ _ Empty = Empty -- error "Internal error: go Empty" + -- Customized version of 'index' that doesn't require a 'Shift'. + index' :: Hash -> Int + index' w = fromIntegral $ w .&. subkeyMask + {-# INLINE index' #-} + + -- Customized version of 'mask' that doesn't require a 'Shift'. + mask' :: Word -> Bitmap + mask' w = 1 `unsafeShiftL` index' w + {-# INLINE mask' #-} + + shiftHash h = h `unsafeShiftR` bitsPerSubkey + {-# INLINE shiftHash #-} + {-# NOINLINE insertKeyExists #-} -- Replace the ith Leaf with Leaf k v. @@ -902,14 +942,14 @@ return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where i = index h s @@ -931,7 +971,7 @@ where go s h1 k1 v1 h2 t2 | bp1 == bp2 = do - st <- go (s+bitsPerSubkey) h1 k1 v1 h2 t2 + st <- go (nextShift s) h1 k1 v1 h2 t2 ary <- A.singletonM st return $ BitmapIndexed bp1 ary | otherwise = do @@ -942,8 +982,15 @@ where bp1 = mask h1 s bp2 = mask h2 s - idx2 | index h1 s < index h2 s = 1 - | otherwise = 0 + !(I# i1) = index h1 s + !(I# i2) = index h2 s + idx2 = I# (i1 Exts.<# i2) + -- This way of computing idx2 saves us a branch compared to the previous approach: + -- + -- idx2 | index h1 s < index h2 s = 1 + -- | otherwise = 0 + -- + -- See https://github.com/haskell-unordered-containers/unordered-containers/issues/75#issuecomment-1128419337 {-# INLINE two #-} -- | \(O(\log n)\) Associate the value with the key in this map. If @@ -984,7 +1031,7 @@ in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st + !st' = go h k (nextShift s) st ary' = A.update ary i $! st' in if ptrEq st st' then t @@ -993,7 +1040,7 @@ i = sparseIndex b m go h k s t@(Full ary) = let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st + !st' = go h k (nextShift s) st ary' = update32 ary i $! st' in if ptrEq st st' then t @@ -1051,14 +1098,14 @@ return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where i = index h s @@ -1084,7 +1131,7 @@ | b .&. m == 0 = t | otherwise = let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st + !st' = go h k (nextShift s) st in if st' `ptrEq` st then t else case st' of @@ -1103,13 +1150,13 @@ i = sparseIndex b m go h k s t@(Full ary) = let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st + !st' = go h k (nextShift s) st in if st' `ptrEq` st then t else case st' of Empty -> let ary' = A.delete ary i - bm = fullNodeMask .&. complement (1 `unsafeShiftL` i) + bm = fullBitmap .&. complement (1 `unsafeShiftL` i) in BitmapIndexed bm ary' _ -> Full (A.update ary i st') where i = index h s @@ -1129,18 +1176,15 @@ -- -- It is only valid to call this when the key exists in the map and you know the -- hash collision position if there was one. This information can be obtained --- from 'lookupRecordCollision'. If there is no collision pass (-1) as collPos. --- --- We can skip: --- - the key equality check on the leaf, if we reach a leaf it must be the key +-- from 'lookupRecordCollision'. If there is no collision, pass (-1) as collPos. deleteKeyExists :: Int -> Hash -> k -> HashMap k v -> HashMap k v -deleteKeyExists !collPos0 !h0 !k0 !m0 = go collPos0 h0 k0 0 m0 +deleteKeyExists !collPos0 !h0 !k0 !m0 = go collPos0 h0 k0 m0 where - go :: Int -> Hash -> k -> Int -> HashMap k v -> HashMap k v - go !_collPos !_h !_k !_s (Leaf _ _) = Empty - go collPos h k s (BitmapIndexed b ary) = + go :: Int -> Word -> k -> HashMap k v -> HashMap k v + go !_collPos !_shiftedHash !_k (Leaf _ _) = Empty + go collPos shiftedHash k (BitmapIndexed b ary) = let !st = A.index ary i - !st' = go collPos h k (s+bitsPerSubkey) st + !st' = go collPos (shiftHash shiftedHash) k st in case st' of Empty | A.length ary == 1 -> Empty | A.length ary == 2 -> @@ -1153,25 +1197,39 @@ bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i) l | isLeafOrCollision l && A.length ary == 1 -> l _ -> BitmapIndexed b (A.update ary i st') - where m = mask h s + where m = mask' shiftedHash i = sparseIndex b m - go collPos h k s (Full ary) = + go collPos shiftedHash k (Full ary) = let !st = A.index ary i - !st' = go collPos h k (s+bitsPerSubkey) st + !st' = go collPos (shiftHash shiftedHash) k st in case st' of Empty -> let ary' = A.delete ary i - bm = fullNodeMask .&. complement (1 `unsafeShiftL` i) + bm = fullBitmap .&. complement (1 `unsafeShiftL` i) in BitmapIndexed bm ary' _ -> Full (A.update ary i st') - where i = index h s - go collPos h _ _ (Collision _hy v) + where i = index' shiftedHash + go collPos _shiftedHash _k (Collision h v) | A.length v == 2 = if collPos == 0 then Leaf h (A.index v 1) else Leaf h (A.index v 0) | otherwise = Collision h (A.delete v collPos) - go !_ !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty" + go !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty" + + -- Customized version of 'index' that doesn't require a 'Shift'. + index' :: Hash -> Int + index' w = fromIntegral $ w .&. subkeyMask + {-# INLINE index' #-} + + -- Customized version of 'mask' that doesn't require a 'Shift'. + mask' :: Word -> Bitmap + mask' w = 1 `unsafeShiftL` index' w + {-# INLINE mask' #-} + + shiftHash h = h `unsafeShiftR` bitsPerSubkey + {-# INLINE shiftHash #-} + {-# NOINLINE deleteKeyExists #-} -- | \(O(\log n)\) Adjust the value tied to a given key in this map only @@ -1201,7 +1259,7 @@ go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st + !st' = go h k (nextShift s) st ary' = A.update ary i $! st' in if ptrEq st st' then t @@ -1211,7 +1269,7 @@ go h k s t@(Full ary) = let i = index h s !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st + !st' = go h k (nextShift s) st ary' = update32 ary i $! st' in if ptrEq st st' then t @@ -1241,11 +1299,19 @@ -- 'lookup' k ('alter' f k m) = f ('lookup' k m) -- @ alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v --- TODO(m-renaud): Consider using specialized insert and delete for alter. alter f k m = - case f (lookup k m) of - Nothing -> delete k m - Just v -> insert k v m + let !h = hash k + !lookupRes = lookupRecordCollision h k m + in case f (lookupResToMaybe lookupRes) of + Nothing -> case lookupRes of + Absent -> m + Present _ collPos -> deleteKeyExists collPos h k m + Just v' -> case lookupRes of + Absent -> insertNewKey h k v' m + Present v collPos -> + if v `ptrEq` v' + then m + else insertKeyExists collPos h k v' m {-# INLINABLE alter #-} -- | \(O(\log n)\) The expression @('alterF' f k map)@ alters the value @x@ at @@ -1388,9 +1454,7 @@ where !h = hash k !lookupRes = lookupRecordCollision h k m - !mv = case lookupRes of - Absent -> Nothing - Present v _ -> Just v + !mv = lookupResToMaybe lookupRes {-# INLINABLE alterFEager #-} -- | \(O(n \log m)\) Inclusion of maps. A map is included in another map if the keys @@ -1458,21 +1522,21 @@ go s t1@(Collision h1 _) (BitmapIndexed b ls2) | b .&. m == 0 = False | otherwise = - go (s+bitsPerSubkey) t1 (A.index ls2 (sparseIndex b m)) + go (nextShift s) t1 (A.index ls2 (sparseIndex b m)) where m = mask h1 s -- Similar to the previous case we need to traverse l2 at the index for the hash h1. go s t1@(Collision h1 _) (Full ls2) = - go (s+bitsPerSubkey) t1 (A.index ls2 (index h1 s)) + go (nextShift s) t1 (A.index ls2 (index h1 s)) -- In cases where the first and second map are BitmapIndexed or Full, -- traverse down the tree at the appropriate indices. go s (BitmapIndexed b1 ls1) (BitmapIndexed b2 ls2) = - submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 b2 ls2 + submapBitmapIndexed (go (nextShift s)) b1 ls1 b2 ls2 go s (BitmapIndexed b1 ls1) (Full ls2) = - submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 fullNodeMask ls2 + submapBitmapIndexed (go (nextShift s)) b1 ls1 fullBitmap ls2 go s (Full ls1) (Full ls2) = - submapBitmapIndexed (go (s+bitsPerSubkey)) fullNodeMask ls1 fullNodeMask ls2 + submapBitmapIndexed (go (nextShift s)) fullBitmap ls1 fullBitmap ls2 -- Collision and Full nodes always contain at least two entries. Hence it -- cannot be a map of a leaf. @@ -1518,14 +1582,14 @@ -- -- >>> union (fromList [(1,'a'),(2,'b')]) (fromList [(2,'c'),(3,'d')]) -- fromList [(1,'a'),(2,'b'),(3,'d')] -union :: (Eq k, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v +union :: Eq k => HashMap k v -> HashMap k v -> HashMap k v union = unionWith const {-# INLINABLE union #-} -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result. -unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v +unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} @@ -1533,7 +1597,7 @@ -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result. -unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v +unionWithKey :: Eq k => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWithKey f = go 0 where @@ -1558,16 +1622,16 @@ -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2 - ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 + ary' = unionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 in bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 + let ary' = unionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 + let ary' = unionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask + let ary' = unionArrayBy (go (nextShift s)) fullBitmap fullBitmap ary1 ary2 in Full ary' -- leaf vs. branch @@ -1576,7 +1640,7 @@ b' = b1 .|. m2 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> - go (s+bitsPerSubkey) st1 t2 + go (nextShift s) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2 @@ -1587,7 +1651,7 @@ b' = b2 .|. m1 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> - go (s+bitsPerSubkey) t1 st2 + go (nextShift s) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1 @@ -1596,12 +1660,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s - ary' = update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 + ary' = update32With' ary1 i $ \st1 -> go (nextShift s) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s - ary' = update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 + ary' = update32With' ary2 i $ \st2 -> go (nextShift s) t1 st2 in Full ary' leafHashCode (Leaf h _) = h @@ -1609,7 +1673,7 @@ leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 - | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (s+bitsPerSubkey) h1 h2 t1 t2) + | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (nextShift s) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where @@ -1654,7 +1718,7 @@ -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets. -unions :: (Eq k, Hashable k) => [HashMap k v] -> HashMap k v +unions :: Eq k => [HashMap k v] -> HashMap k v unions = List.foldl' union empty {-# INLINE unions #-} @@ -1703,9 +1767,6 @@ map f = mapWithKey (const f) {-# INLINE map #-} --- TODO: We should be able to use mutation to create the new --- 'HashMap'. - -- | \(O(n)\) Perform an 'Applicative' action for each key-value pair -- in a 'HashMap' and produce a 'HashMap' of all the results. -- @@ -1772,21 +1833,21 @@ -- | \(O(n \log m)\) Intersection of two maps. Return elements of the first -- map for keys existing in the second. -intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v +intersection :: Eq k => HashMap k v -> HashMap k w -> HashMap k v intersection = Exts.inline intersectionWith const {-# INLINABLE intersection #-} -- | \(O(n \log m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. -intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 +intersectionWith :: Eq k => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f = Exts.inline intersectionWithKey $ const f {-# INLINABLE intersectionWith #-} -- | \(O(n \log m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. -intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 +intersectionWithKey :: Eq k => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWithKey f = intersectionWithKey# $ \k v1 v2 -> (# f k v1 v2 #) {-# INLINABLE intersectionWithKey #-} @@ -1811,30 +1872,30 @@ go _ (Collision h1 ls1) (Collision h2 ls2) = intersectionCollisions f h1 h2 ls1 ls2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = - intersectionArrayBy (go (s + bitsPerSubkey)) b1 b2 ary1 ary2 + intersectionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 go s (BitmapIndexed b1 ary1) (Full ary2) = - intersectionArrayBy (go (s + bitsPerSubkey)) b1 fullNodeMask ary1 ary2 + intersectionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 go s (Full ary1) (BitmapIndexed b2 ary2) = - intersectionArrayBy (go (s + bitsPerSubkey)) fullNodeMask b2 ary1 ary2 + intersectionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 go s (Full ary1) (Full ary2) = - intersectionArrayBy (go (s + bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 + intersectionArrayBy (go (nextShift s)) fullBitmap fullBitmap ary1 ary2 -- collision vs. branch go s (BitmapIndexed b1 ary1) t2@(Collision h2 _ls2) | b1 .&. m2 == 0 = Empty - | otherwise = go (s + bitsPerSubkey) (A.index ary1 i) t2 + | otherwise = go (nextShift s) (A.index ary1 i) t2 where m2 = mask h2 s i = sparseIndex b1 m2 go s t1@(Collision h1 _ls1) (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = Empty - | otherwise = go (s + bitsPerSubkey) t1 (A.index ary2 i) + | otherwise = go (nextShift s) t1 (A.index ary2 i) where m1 = mask h1 s i = sparseIndex b2 m1 - go s (Full ary1) t2@(Collision h2 _ls2) = go (s + bitsPerSubkey) (A.index ary1 i) t2 + go s (Full ary1) t2@(Collision h2 _ls2) = go (nextShift s) (A.index ary1 i) t2 where i = index h2 s - go s t1@(Collision h1 _ls1) (Full ary2) = go (s + bitsPerSubkey) t1 (A.index ary2 i) + go s t1@(Collision h1 _ls1) (Full ary2) = go (nextShift s) t1 (A.index ary2 i) where i = index h1 s {-# INLINE intersectionWithKey# #-} @@ -2080,7 +2141,7 @@ | Just t' <- onLeaf t = t' | otherwise = Empty go (BitmapIndexed b ary) = filterA ary b - go (Full ary) = filterA ary fullNodeMask + go (Full ary) = filterA ary fullBitmap go (Collision h ary) = filterC ary h filterA ary0 b0 = @@ -2099,9 +2160,9 @@ ch <- A.read mary 0 case ch of t | isLeafOrCollision t -> return t - _ -> BitmapIndexed b <$> A.trim mary 1 + _ -> BitmapIndexed b <$> (A.unsafeFreeze =<< A.shrink mary 1) _ -> do - ary2 <- A.trim mary j + ary2 <- A.unsafeFreeze =<< A.shrink mary j return $! if j == maxChildren then Full ary2 else BitmapIndexed b ary2 @@ -2128,7 +2189,7 @@ return $! Leaf h l _ | i == j -> do ary2 <- A.unsafeFreeze mary return $! Collision h ary2 - | otherwise -> do ary2 <- A.trim mary j + | otherwise -> do ary2 <- A.unsafeFreeze =<< A.shrink mary j return $! Collision h ary2 | Just el <- onColl $! A.index ary i = A.write mary j el >> step ary mary (i+1) (j+1) n @@ -2197,7 +2258,7 @@ -- > = fromList [('a', [3, 1]), ('b', [2])] -- -- Note that the lists in the resulting map contain elements in reverse order --- from their occurences in the original list. +-- from their occurrences in the original list. -- -- More generally, duplicate entries are accumulated as follows; -- this matters when @f@ is not commutative or not associative. @@ -2411,7 +2472,7 @@ mask w s = 1 `unsafeShiftL` index w s {-# INLINE mask #-} --- | This array index is computed by counting the number of bits below the +-- | This array index is computed by counting the number of 1-bits below the -- 'index' represented by the mask. -- -- >>> sparseIndex 0b0110_0110 0b0010_0000 @@ -2426,15 +2487,18 @@ sparseIndex b m = popCount (b .&. (m - 1)) {-# INLINE sparseIndex #-} --- TODO: Should be named _(bit)map_ instead of _mask_ - -- | A bitmap with the 'maxChildren' least significant bits set, i.e. -- @0xFF_FF_FF_FF@. -fullNodeMask :: Bitmap +fullBitmap :: Bitmap -- This needs to use 'shiftL' instead of 'unsafeShiftL', to avoid UB. -- See issue #412. -fullNodeMask = complement (complement 0 `shiftL` maxChildren) -{-# INLINE fullNodeMask #-} +fullBitmap = complement (complement 0 `shiftL` maxChildren) +{-# INLINE fullBitmap #-} + +-- | Increment a 'Shift' for use at the next deeper level. +nextShift :: Shift -> Shift +nextShift s = s + bitsPerSubkey +{-# INLINE nextShift #-} ------------------------------------------------------------------------ -- Pointer equality diff --git a/src/Data/Strict/HashMap/Autogen/Internal/Array.hs b/src/Data/Strict/HashMap/Autogen/Internal/Array.hs --- a/src/Data/Strict/HashMap/Autogen/Internal/Array.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal/Array.hs @@ -52,7 +52,6 @@ , insertM , delete , sameArray1 - , trim , unsafeFreeze , unsafeThaw @@ -60,6 +59,7 @@ , run , copy , copyM + , cloneM -- * Folds , foldl @@ -94,7 +94,7 @@ unsafeFreezeSmallArray#, unsafeThawSmallArray#, writeSmallArray#) import GHC.ST (ST (..)) -import Prelude hiding (all, filter, foldMap, foldl, foldr, length, +import Prelude hiding (Foldable(..), all, filter, map, read, traverse) import qualified GHC.Exts as Exts @@ -322,11 +322,6 @@ case cloneSmallMutableArray# mary# off# len# s of (# s', mary'# #) -> (# s', MArray mary'# #) --- | Create a new array of the @n@ first elements of @mary@. -trim :: MArray s a -> Int -> ST s (Array a) -trim mary n = cloneM mary 0 n >>= unsafeFreeze -{-# INLINE trim #-} - -- | \(O(n)\) Insert an element at the given position in this array, -- increasing its size by one. insert :: Array e -> Int -> e -> Array e @@ -360,7 +355,7 @@ where !count = length ary {-# INLINE updateM #-} --- | \(O(n)\) Update the element at the given positio in this array, by +-- | \(O(n)\) Update the element at the given position in this array, by -- applying a function to it. Evaluates the element to WHNF before -- inserting it into the array. updateWith' :: Array e -> Int -> (e -> e) -> Array e diff --git a/src/Data/Strict/HashMap/Autogen/Internal/Debug.hs b/src/Data/Strict/HashMap/Autogen/Internal/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Strict/HashMap/Autogen/Internal/Debug.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +-- | = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- Debugging utilities for 'HashMap's. + +module Data.Strict.HashMap.Autogen.Internal.Debug + ( valid + , Validity(..) + , Error(..) + , SubHash + , SubHashPath + ) where + +import Data.Bits (complement, countTrailingZeros, popCount, shiftL, + unsafeShiftL, (.&.), (.|.)) +import Data.Hashable (Hashable) +import Data.Strict.HashMap.Autogen.Internal (Bitmap, Hash, HashMap (..), Leaf (..), + bitsPerSubkey, fullBitmap, hash, + isLeafOrCollision, maxChildren, sparseIndex) +import Data.Semigroup (Sum (..)) + +import qualified Data.Strict.HashMap.Autogen.Internal.Array as A + + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup (..)) +#endif + +data Validity k = Invalid (Error k) SubHashPath | Valid + deriving (Eq, Show) + +instance Semigroup (Validity k) where + Valid <> y = y + x <> _ = x + +instance Monoid (Validity k) where + mempty = Valid + mappend = (<>) + +-- | An error corresponding to a broken invariant. +-- +-- See 'HashMap' for the documentation of the invariants. +data Error k + = INV1_internal_Empty + | INV2_Bitmap_unexpected_1_bits !Bitmap + | INV3_bad_BitmapIndexed_size !Int + | INV4_bitmap_array_size_mismatch !Bitmap !Int + | INV5_BitmapIndexed_invalid_single_subtree + | INV6_misplaced_hash !Hash + | INV7_key_hash_mismatch k !Hash + | INV8_bad_Full_size !Int + | INV9_Collision_size !Int + | INV10_Collision_duplicate_key k !Hash + deriving (Eq, Show) + +-- TODO: Name this 'Index'?! +-- (https://github.com/haskell-unordered-containers/unordered-containers/issues/425) +-- | A part of a 'Hash' with 'bitsPerSubkey' bits. +type SubHash = Word + +data SubHashPath = SubHashPath + { partialHash :: !Word + -- ^ The bits we already know, starting from the lower bits. + -- The unknown upper bits are @0@. + , lengthInBits :: !Int + -- ^ The number of bits known. + } deriving (Eq, Show) + +initialSubHashPath :: SubHashPath +initialSubHashPath = SubHashPath 0 0 + +addSubHash :: SubHashPath -> SubHash -> SubHashPath +addSubHash (SubHashPath ph l) sh = + SubHashPath (ph .|. (sh `unsafeShiftL` l)) (l + bitsPerSubkey) + +hashMatchesSubHashPath :: SubHashPath -> Hash -> Bool +hashMatchesSubHashPath (SubHashPath ph l) h = maskToLength h l == ph + where + -- Note: This needs to use `shiftL` instead of `unsafeShiftL` because + -- @l'@ may be greater than 32/64 at the deepest level. + maskToLength h' l' = h' .&. complement (complement 0 `shiftL` l') + +valid :: Hashable k => HashMap k v -> Validity k +valid Empty = Valid +valid t = validInternal initialSubHashPath t + where + validInternal p Empty = Invalid INV1_internal_Empty p + validInternal p (Leaf h l) = validHash p h <> validLeaf p h l + validInternal p (Collision h ary) = validHash p h <> validCollision p h ary + validInternal p (BitmapIndexed b ary) = validBitmapIndexed p b ary + validInternal p (Full ary) = validFull p ary + + validHash p h | hashMatchesSubHashPath p h = Valid + | otherwise = Invalid (INV6_misplaced_hash h) p + + validLeaf p h (L k _) | hash k == h = Valid + | otherwise = Invalid (INV7_key_hash_mismatch k h) p + + validCollision p h ary = validCollisionSize <> A.foldMap (validLeaf p h) ary <> distinctKeys + where + n = A.length ary + validCollisionSize | n < 2 = Invalid (INV9_Collision_size n) p + | otherwise = Valid + distinctKeys = A.foldMap (\(L k _) -> appearsOnce k) ary + appearsOnce k | A.foldMap (\(L k' _) -> if k' == k then Sum @Int 1 else Sum 0) ary == 1 = Valid + | otherwise = Invalid (INV10_Collision_duplicate_key k h) p + + validBitmapIndexed p b ary = validBitmap <> validArraySize <> validSubTrees p b ary + where + validBitmap | b .&. complement fullBitmap == 0 = Valid + | otherwise = Invalid (INV2_Bitmap_unexpected_1_bits b) p + n = A.length ary + validArraySize | n < 1 || n >= maxChildren = Invalid (INV3_bad_BitmapIndexed_size n) p + | popCount b == n = Valid + | otherwise = Invalid (INV4_bitmap_array_size_mismatch b n) p + + validSubTrees p b ary + | A.length ary == 1 + , isLeafOrCollision (A.index ary 0) + = Invalid INV5_BitmapIndexed_invalid_single_subtree p + | otherwise = go b + where + go 0 = Valid + go b' = validInternal (addSubHash p (fromIntegral c)) (A.index ary i) <> go b'' + where + c = countTrailingZeros b' + m = 1 `unsafeShiftL` c + i = sparseIndex b m + b'' = b' .&. complement m + + validFull p ary = validArraySize <> validSubTrees p fullBitmap ary + where + n = A.length ary + validArraySize | n == maxChildren = Valid + | otherwise = Invalid (INV8_bad_Full_size n) p diff --git a/src/Data/Strict/HashMap/Autogen/Internal/List.hs b/src/Data/Strict/HashMap/Autogen/Internal/List.hs --- a/src/Data/Strict/HashMap/Autogen/Internal/List.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal/List.hs @@ -32,7 +32,7 @@ import Data.Semigroup ((<>)) #endif --- Note: previous implemenation isPermutation = null (as // bs) +-- Note: previous implementation isPermutation = null (as // bs) -- was O(n^2) too. -- -- This assumes lists are of equal length @@ -53,7 +53,7 @@ -- The idea: -- --- Homogeonous version +-- Homogenous version -- -- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- uc c as bs = compare (sortBy c as) (sortBy c bs) diff --git a/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs b/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs --- a/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs +++ b/src/Data/Strict/HashMap/Autogen/Internal/Strict.hs @@ -130,8 +130,8 @@ -- See Note [Imports from Data.Strict.HashMap.Autogen.Internal] import Data.Hashable (Hashable) import Data.Strict.HashMap.Autogen.Internal (Hash, HashMap (..), Leaf (..), LookupRes (..), - bitsPerSubkey, fullNodeMask, hash, index, mask, - ptrEq, sparseIndex) + fullBitmap, hash, index, mask, nextShift, ptrEq, + sparseIndex) import Prelude hiding (lookup, map) -- See Note [Imports from Data.Strict.HashMap.Autogen.Internal] @@ -203,14 +203,14 @@ in HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i - st' = go h k x (s+bitsPerSubkey) st + st' = go h k x (nextShift s) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let st = A.index ary i - st' = go h k x (s+bitsPerSubkey) st + st' = go h k x (nextShift s) st ary' = HM.update32 ary i $! st' in Full ary' where i = index h s @@ -244,14 +244,14 @@ return $! HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where i = index h s @@ -273,7 +273,7 @@ go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let st = A.index ary i - st' = go h k (s+bitsPerSubkey) st + st' = go h k (nextShift s) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s @@ -281,7 +281,7 @@ go h k s (Full ary) = let i = index h s st = A.index ary i - st' = go h k (s+bitsPerSubkey) st + st' = go h k (nextShift s) st ary' = HM.update32 ary i $! st' in Full ary' go h k _ t@(Collision hy v) @@ -306,9 +306,18 @@ -- @ alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v alter f k m = - case f (HM.lookup k m) of - Nothing -> HM.delete k m - Just v -> insert k v m + let !h = hash k + !lookupRes = HM.lookupRecordCollision h k m + in case f (HM.lookupResToMaybe lookupRes) of + Nothing -> case lookupRes of + Absent -> m + Present _ collPos -> HM.deleteKeyExists collPos h k m + Just !v' -> case lookupRes of + Absent -> HM.insertNewKey h k v' m + Present v collPos -> + if v `ptrEq` v' + then m + else HM.insertKeyExists collPos h k v' m {-# INLINABLE alter #-} -- | \(O(\log n)\) The expression (@'alterF' f k map@) alters the value @x@ at @@ -429,9 +438,7 @@ where !h = hash k !lookupRes = HM.lookupRecordCollision h k m - !mv = case lookupRes of - Absent -> Nothing - Present v _ -> Just v + !mv = HM.lookupResToMaybe lookupRes {-# INLINABLE alterFEager #-} ------------------------------------------------------------------------ @@ -439,14 +446,14 @@ -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. -unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v +unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. -unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v +unionWithKey :: Eq k => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWithKey f = go 0 where @@ -471,16 +478,16 @@ -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2 - ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 + ary' = HM.unionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 in HM.bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = - let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 + let ary' = HM.unionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = - let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 + let ary' = HM.unionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = - let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask + let ary' = HM.unionArrayBy (go (nextShift s)) fullBitmap fullBitmap ary1 ary2 in Full ary' -- leaf vs. branch @@ -489,7 +496,7 @@ b' = b1 .|. m2 in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> - go (s+bitsPerSubkey) st1 t2 + go (nextShift s) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2 @@ -500,7 +507,7 @@ b' = b2 .|. m1 in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> - go (s+bitsPerSubkey) t1 st2 + go (nextShift s) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1 @@ -509,12 +516,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s - ary' = HM.update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 + ary' = HM.update32With' ary1 i $ \st1 -> go (nextShift s) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s - ary' = HM.update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 + ary' = HM.update32With' ary2 i $ \st2 -> go (nextShift s) t1 st2 in Full ary' leafHashCode (Leaf h _) = h @@ -522,7 +529,7 @@ leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 - | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (s+bitsPerSubkey) h1 h2 t1 t2) + | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (nextShift s) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where @@ -615,7 +622,7 @@ -- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. -intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 +intersectionWith :: Eq k => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f = Exts.inline intersectionWithKey $ const f {-# INLINABLE intersectionWith #-} @@ -623,7 +630,7 @@ -- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. -intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) +intersectionWithKey :: Eq k => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWithKey f = HM.intersectionWithKey# $ \k v1 v2 -> let !v3 = f k v1 v2 in (# v3 #) {-# INLINABLE intersectionWithKey #-} @@ -661,7 +668,7 @@ -- > = fromList [('a', [3, 1]), ('b', [2])] -- -- Note that the lists in the resulting map contain elements in reverse order --- from their occurences in the original list. +-- from their occurrences in the original list. -- -- More generally, duplicate entries are accumulated as follows; -- this matters when @f@ is not commutative or not associative. diff --git a/src/Data/Strict/IntMap/Autogen/Internal.hs b/src/Data/Strict/IntMap/Autogen/Internal.hs --- a/src/Data/Strict/IntMap/Autogen/Internal.hs +++ b/src/Data/Strict/IntMap/Autogen/Internal.hs @@ -72,6 +72,7 @@ -- constructors are ordered by frequency. -- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil -- improves the benchmark by circa 10%. +-- module Data.Strict.IntMap.Autogen.Internal ( -- * Map type @@ -228,6 +229,10 @@ , partition , partitionWithKey + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + , mapMaybe , mapMaybeWithKey , mapEither @@ -294,7 +299,6 @@ ) where import Data.Functor.Identity (Identity (..)) -import Control.Applicative (liftA2) import Data.Semigroup (Semigroup(stimes)) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup((<>))) @@ -306,7 +310,9 @@ import Data.Bits import qualified Data.Foldable as Foldable import Data.Maybe (fromMaybe) -import Prelude hiding (lookup, map, filter, foldr, foldl, null) +import Data.Strict.ContainersUtils.Autogen.Prelude hiding + (lookup, map, filter, foldr, foldl, foldl', null) +import Prelude () import Data.IntSet.Internal (Key) import qualified Data.IntSet.Internal as IntSet @@ -321,6 +327,8 @@ import qualified GHC.Exts as GHCExts import Text.Read import Language.Haskell.TH.Syntax (Lift) +-- See Note [ Template Haskell Dependencies ] +import Language.Haskell.TH () #endif import qualified Control.Category as Category @@ -371,7 +379,7 @@ type IntSetPrefix = Int type IntSetBitMap = Word --- | @since FIXME +-- | @since 0.6.6 deriving instance Lift a => Lift (IntMap a) bitmapOf :: Int -> IntSetBitMap @@ -610,7 +618,7 @@ | otherwise = def go Nil = def --- | \(O(\log n)\). Find largest key smaller than the given one and return the +-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the -- corresponding (key, value) pair. -- -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing @@ -631,7 +639,7 @@ | otherwise = Just (ky, y) go def Nil = unsafeFindMax def --- | \(O(\log n)\). Find smallest key greater than the given one and return the +-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the -- corresponding (key, value) pair. -- -- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') @@ -652,7 +660,7 @@ | otherwise = Just (ky, y) go def Nil = unsafeFindMin def --- | \(O(\log n)\). Find largest key smaller or equal to the given one and return +-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing @@ -674,7 +682,7 @@ | otherwise = Just (ky, y) go def Nil = unsafeFindMax def --- | \(O(\log n)\). Find smallest key greater or equal to the given one and return +-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return -- the corresponding (key, value) pair. -- -- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') @@ -822,6 +830,8 @@ -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +-- +-- Also see the performance note on 'fromListWith'. insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith f k x t @@ -837,6 +847,8 @@ -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +-- +-- Also see the performance note on 'fromListWith'. insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWithKey f !k x t@(Bin p m l r) @@ -862,6 +874,8 @@ -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +-- +-- Also see the performance note on 'fromListWith'. insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) insertLookupWithKey f !k x t@(Bin p m l r) @@ -1004,7 +1018,7 @@ Just x -> Tip k x Nothing -> Nil --- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at +-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, -- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f -- ('lookup' k m)@. @@ -1077,6 +1091,8 @@ -- | \(O(n+m)\). The union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a unionWith f m1 m2 @@ -1086,6 +1102,8 @@ -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a unionWithKey f m1 m2 @@ -1130,7 +1148,7 @@ -- | \(O(n+m)\). Remove all the keys in a given set from a map. -- -- @ --- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.notMember`` s) m +-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.notMember`` s) m -- @ -- -- @since 0.5.8 @@ -1208,7 +1226,7 @@ -- | \(O(n+m)\). The restriction of a map to the keys in a set. -- -- @ --- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.member`` s) m +-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.member`` s) m -- @ -- -- @since 0.5.8 @@ -2532,12 +2550,14 @@ -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" +-- +-- Also see the performance note on 'fromListWith'. mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] --- | \(O(n \min(n,W))\). +-- | \(O(n)\). -- @'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@. @@ -2615,6 +2635,101 @@ | otherwise -> (Nil :*: t) Nil -> (Nil :*: Nil) +-- | \(O(\min(n,W))\). Take while a predicate on the keys holds. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- See note at 'spanAntitone'. +-- +-- @ +-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList' +-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k) +-- @ +-- +-- @since 0.6.7 +takeWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a +takeWhileAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then bin p m (go predicate l) r + else go predicate r + _ -> go predicate t + where + go predicate' (Bin p m l r) + | predicate' $! p+m = bin p m l (go predicate' r) + | otherwise = go predicate' l + go predicate' t'@(Tip ky _) + | predicate' ky = t' + | otherwise = Nil + go _ Nil = Nil + +-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- See note at 'spanAntitone'. +-- +-- @ +-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList' +-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k)) +-- @ +-- +-- @since 0.6.7 +dropWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a +dropWhileAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then go predicate l + else bin p m l (go predicate r) + _ -> go predicate t + where + go predicate' (Bin p m l r) + | predicate' $! p+m = go predicate' r + | otherwise = bin p m (go predicate' l) r + go predicate' t'@(Tip ky _) + | predicate' ky = Nil + | otherwise = t' + go _ Nil = Nil + +-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding. +-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@. +-- +-- @ +-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs) +-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs +-- @ +-- +-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map +-- at some /unspecified/ point. +-- +-- @since 0.6.7 +spanAntitone :: (Key -> Bool) -> IntMap a -> (IntMap a, IntMap a) +spanAntitone predicate t = + case t of + Bin p m l r + | m < 0 -> + if predicate 0 -- handle negative numbers. + then + case go predicate l of + (lt :*: gt) -> + let !lt' = bin p m lt r + in (lt', gt) + else + case go predicate r of + (lt :*: gt) -> + let !gt' = bin p m l gt + in (lt, gt') + _ -> case go predicate t of + (lt :*: gt) -> (lt, gt) + where + go predicate' (Bin p m l r) + | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt + | otherwise = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r + go predicate' t'@(Tip ky _) + | predicate' ky = (t' :*: Nil) + | otherwise = (Nil :*: t') + go _ Nil = (Nil :*: Nil) + -- | \(O(n)\). Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing @@ -2684,26 +2799,26 @@ split :: Key -> IntMap a -> (IntMap a, IntMap a) split k t = case t of - Bin _ m l r + Bin p m l r | m < 0 -> if k >= 0 -- handle negative numbers. then case go k l of (lt :*: gt) -> - let !lt' = union r lt + let !lt' = bin p m lt r in (lt', gt) else case go k r of (lt :*: gt) -> - let !gt' = union gt l + let !gt' = bin p m l gt in (lt, gt') _ -> case go k t of (lt :*: gt) -> (lt, gt) where go k' t'@(Bin p m l r) | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t' - | zero k' m = case go k' l of (lt :*: gt) -> lt :*: union gt r - | otherwise = case go k' r of (lt :*: gt) -> union l lt :*: gt + | zero k' m = case go k' l of (lt :*: gt) -> lt :*: bin p m gt r + | otherwise = case go k' r of (lt :*: gt) -> bin p m l lt :*: gt go k' t'@(Tip ky _) | k' > ky = (t' :*: Nil) | k' < ky = (Nil :*: t') @@ -2734,11 +2849,11 @@ splitLookup k t = case case t of - Bin _ m l r + Bin p m l r | m < 0 -> if k >= 0 -- handle negative numbers. - then mapLT (union r) (go k l) - else mapGT (`union` l) (go k r) + then mapLT (flip (bin p m) r) (go k l) + else mapGT (bin p m l) (go k r) _ -> go k t of SplitLookup lt fnd gt -> (lt, fnd, gt) where @@ -2747,8 +2862,8 @@ if k' > p then SplitLookup t' Nothing Nil else SplitLookup Nil Nothing t' - | zero k' m = mapGT (`union` r) (go k' l) - | otherwise = mapLT (union l) (go k' r) + | zero k' m = mapGT (flip (bin p m) r) (go k' l) + | otherwise = mapLT (bin p m l) (go k' r) go k' t'@(Tip ky y) | k' > ky = SplitLookup t' Nothing Nil | k' < ky = SplitLookup Nil Nothing t' @@ -2960,7 +3075,7 @@ assocs :: IntMap a -> [(Key,a)] assocs = toAscList --- | \(O(n \min(n,W))\). The set of all keys of the map. +-- | \(O(n)\). The set of all keys of the map. -- -- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5] -- > keysSet empty == Data.IntSet.empty @@ -3092,10 +3207,41 @@ where ins t (k,x) = insert k x t --- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty +-- +-- Note the reverse ordering of @"cba"@ in the example. +-- +-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@. +-- +-- === Performance +-- +-- You should ensure that the given @f@ is fast with this order of arguments. +-- +-- Symmetric functions may be slow in one order, and fast in another. +-- For the common case of collecting values of matching keys in a list, as above: +-- +-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument. +-- Thus: +-- +-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast +-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow +-- +-- because they evaluate as, respectively: +-- +-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n) +-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²) +-- +-- Thus, to get good performance with an operation like @(++)@ while also preserving +-- the same order as in the input list, reverse the input: +-- +-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")] +-- +-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in: +-- +-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a fromListWith f xs @@ -3103,9 +3249,11 @@ -- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. -- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] -- > fromListWithKey f [] == empty +-- +-- Also see the performance note on 'fromListWith'. fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromListWithKey f xs @@ -3128,6 +3276,8 @@ -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] +-- +-- Also see the performance note on 'fromListWith'. fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) @@ -3139,6 +3289,8 @@ -- -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] +-- +-- Also see the performance note on 'fromListWith'. fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromAscListWithKey f = fromMonoListWithKey Nondistinct f @@ -3160,6 +3312,8 @@ -- The precise conditions under which this function works are subtle: -- For any branch mask, keys with the same prefix w.r.t. the branch -- mask must occur consecutively in the list. +-- +-- Also see the performance note on 'fromListWith'. fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromMonoListWithKey distinct f = go @@ -3449,14 +3603,14 @@ Debugging --------------------------------------------------------------------} --- | \(O(n)\). Show the tree that implements the map. The tree is shown +-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. showTree :: Show a => IntMap a -> String showTree s = showTreeWith True False s -{- | \(O(n)\). The expression (@'showTreeWith' hang wide map@) shows +{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows the tree that implements the map. If @hang@ is 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown. @@ -3505,7 +3659,7 @@ showsBars bars = case bars of [] -> id - _ -> showString (concat (reverse (tail bars))) . showString node + _ : tl -> showString (concat (reverse tl)) . showString node node :: String node = "+--" diff --git a/src/Data/Strict/IntMap/Autogen/Strict.hs b/src/Data/Strict/IntMap/Autogen/Strict.hs --- a/src/Data/Strict/IntMap/Autogen/Strict.hs +++ b/src/Data/Strict/IntMap/Autogen/Strict.hs @@ -217,6 +217,10 @@ , partition , partitionWithKey + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + , mapMaybe , mapMaybeWithKey , mapEither diff --git a/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs b/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs --- a/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs +++ b/src/Data/Strict/IntMap/Autogen/Strict/Internal.hs @@ -217,6 +217,10 @@ , partition , partitionWithKey + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone + , mapMaybe , mapMaybeWithKey , mapEither @@ -255,7 +259,9 @@ #endif ) where -import Prelude hiding (lookup,map,filter,foldr,foldl,null) +import Data.Strict.ContainersUtils.Autogen.Prelude hiding + (lookup,map,filter,foldr,foldl,foldl',null) +import Prelude () import Data.Bits import qualified Data.Strict.IntMap.Autogen.Internal as L @@ -327,6 +333,9 @@ , null , partition , partitionWithKey + , takeWhileAntitone + , dropWhileAntitone + , spanAntitone , restrictKeys , size , split @@ -345,7 +354,6 @@ import qualified Data.IntSet.Internal as IntSet import Data.Strict.ContainersUtils.Autogen.BitUtil import Data.Strict.ContainersUtils.Autogen.StrictPair -import Control.Applicative (Applicative (..), liftA2) import qualified Data.Foldable as Foldable {-------------------------------------------------------------------- @@ -417,6 +425,8 @@ -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +-- +-- Also see the performance note on 'fromListWith'. insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith f k x t @@ -435,6 +445,8 @@ -- -- If the key exists in the map, this function is lazy in @value@ but strict -- in the result of @f@. +-- +-- Also see the performance note on 'fromListWith'. insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWithKey f !k x t = @@ -462,6 +474,8 @@ -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +-- +-- Also see the performance note on 'fromListWith'. insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0 @@ -652,6 +666,8 @@ -- | \(O(n+m)\). The union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a unionWith f m1 m2 @@ -661,6 +677,8 @@ -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a unionWithKey f m1 m2 @@ -978,6 +996,8 @@ -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" +-- +-- Also see the performance note on 'fromListWith'. mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] @@ -1087,10 +1107,41 @@ where ins t (k,x) = insert k x t --- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty +-- +-- Note the reverse ordering of @"cba"@ in the example. +-- +-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@. +-- +-- === Performance +-- +-- You should ensure that the given @f@ is fast with this order of arguments. +-- +-- Symmetric functions may be slow in one order, and fast in another. +-- For the common case of collecting values of matching keys in a list, as above: +-- +-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument. +-- Thus: +-- +-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast +-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow +-- +-- because they evaluate as, respectively: +-- +-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n) +-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²) +-- +-- Thus, to get good performance with an operation like @(++)@ while also preserving +-- the same order as in the input list, reverse the input: +-- +-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")] +-- +-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in: +-- +-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a fromListWith f xs @@ -1098,8 +1149,11 @@ -- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. -- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] --- > fromListWith (++) [] == empty +-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- > fromListWithKey f [] == empty +-- +-- Also see the performance note on 'fromListWith'. fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromListWithKey f xs @@ -1122,6 +1176,8 @@ -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] +-- +-- Also see the performance note on 'fromListWith'. fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) @@ -1132,6 +1188,8 @@ -- /The precondition (input list is ascending) is not checked./ -- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] +-- +-- Also see the performance note on 'fromListWith'. fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromAscListWithKey f = fromMonoListWithKey Nondistinct f @@ -1153,6 +1211,8 @@ -- The precise conditions under which this function works are subtle: -- For any branch mask, keys with the same prefix w.r.t. the branch -- mask must occur consecutively in the list. +-- +-- Also see the performance note on 'fromListWith'. fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromMonoListWithKey distinct f = go diff --git a/src/Data/Strict/Map/Autogen/Internal.hs b/src/Data/Strict/Map/Autogen/Internal.hs --- a/src/Data/Strict/Map/Autogen/Internal.hs +++ b/src/Data/Strict/Map/Autogen/Internal.hs @@ -355,8 +355,15 @@ , link , link2 , glue + , fromDistinctAscList_linkTop + , fromDistinctAscList_linkAll + , fromDistinctDescList_linkTop + , fromDistinctDescList_linkAll , MaybeS(..) , Identity(..) + , FromDistinctMonoState(..) + , Stack(..) + , foldl'Stack -- Used by Map.Merge.Lazy , mapWhenMissing @@ -380,10 +387,10 @@ import Control.DeepSeq (NFData(rnf)) import Data.Bits (shiftL, shiftR) import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) import Data.Bifoldable -#endif -import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop) +import Data.Strict.ContainersUtils.Autogen.Prelude hiding + (lookup, map, filter, foldr, foldl, foldl', null, splitAt, take, drop) +import Prelude () import qualified Data.Set.Internal as Set import Data.Set.Internal (Set) @@ -398,6 +405,8 @@ #if __GLASGOW_HASKELL__ import GHC.Exts (build, lazy) import Language.Haskell.TH.Syntax (Lift) +-- See Note [ Template Haskell Dependencies ] +import Language.Haskell.TH () # ifdef USE_MAGIC_PROXY import GHC.Exts (Proxy#, proxy# ) # endif @@ -468,7 +477,7 @@ #endif #ifdef __GLASGOW_HASKELL__ --- | @since FIXME +-- | @since 0.6.6 deriving instance (Lift k, Lift a) => Lift (Map k a) #endif @@ -844,6 +853,8 @@ -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +-- +-- Also see the performance note on 'fromListWith'. insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith = go @@ -870,6 +881,8 @@ -- the map, the key is left alone, not replaced. The combining -- function is flipped--it is applied to the old value and then the -- new value. +-- +-- Also see the performance note on 'fromListWith'. insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWithR = go @@ -898,6 +911,8 @@ -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +-- +-- Also see the performance note on 'fromListWith'. -- See Note: Type of local 'go' function insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a @@ -920,6 +935,9 @@ -- the map, the key is left alone, not replaced. The combining -- function is flipped--it is applied to the old value and then the -- new value. +-- +-- Also see the performance note on 'fromListWith'. + insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a insertWithKeyR = go where @@ -951,6 +969,8 @@ -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +-- +-- Also see the performance note on 'fromListWith'. -- See Note: Type of local 'go' function insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a @@ -1487,7 +1507,7 @@ where sizeL = size l --- | Take a given number of entries in key order, beginning +-- | \(O(\log n)\). Take a given number of entries in key order, beginning -- with the smallest keys. -- -- @ @@ -1509,7 +1529,7 @@ EQ -> l where sizeL = size l --- | Drop a given number of entries in key order, beginning +-- | \(O(\log n)\). Drop a given number of entries in key order, beginning -- with the smallest keys. -- -- @ @@ -1629,11 +1649,6 @@ | Just r <- lookupMin t = r | otherwise = error "Map.findMin: empty map has no minimal element" --- | \(O(\log n)\). The maximal key of the map. Calls 'error' if the map is empty. --- --- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a") --- > findMax empty Error: empty map has no maximal element - lookupMaxSure :: k -> a -> Map k a -> (k, a) lookupMaxSure k a Tip = (k, a) lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r @@ -1649,6 +1664,11 @@ lookupMax Tip = Nothing lookupMax (Bin _ k x _ r) = Just $! lookupMaxSure k x r +-- | \(O(\log n)\). The maximal key of the map. Calls 'error' if the map is empty. +-- +-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a") +-- > findMax empty Error: empty map has no maximal element + findMax :: Map k a -> (k,a) findMax t | Just r <- lookupMax t = r @@ -1802,7 +1822,7 @@ {-# INLINABLE unionsWith #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). -- 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'@). @@ -1826,9 +1846,11 @@ {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------} --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Union with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a -- QuickCheck says pointer equality never happens here. @@ -1846,11 +1868,13 @@ {-# INLINABLE unionWith #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). -- Union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a unionWithKey _f t1 Tip = t1 @@ -1877,7 +1901,7 @@ -- relies on doing it the way we do, and it's not clear whether that -- bound holds the other way. --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Difference of two maps. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Difference of two maps. -- Return elements of the first map not existing in the second map. -- -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" @@ -1896,10 +1920,10 @@ {-# INLINABLE difference #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Remove all keys in a 'Set' from a 'Map'. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Remove all keys in a 'Set' from a 'Map'. -- -- @ --- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m +-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Set.notMember`` s) m -- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s -- @ -- @@ -1955,7 +1979,7 @@ {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection of two maps. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection of two maps. -- Return data in the first map for the keys existing in both maps. -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). -- @@ -1977,11 +2001,11 @@ {-# INLINABLE intersection #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Restrict a 'Map' to only those keys +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Restrict a 'Map' to only those keys -- found in a 'Set'. -- -- @ --- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m +-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Set.member`` s) m -- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s -- @ -- @@ -2002,7 +2026,7 @@ {-# INLINABLE restrictKeys #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -2022,7 +2046,7 @@ {-# INLINABLE intersectionWith #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" @@ -2044,7 +2068,7 @@ {-------------------------------------------------------------------- Disjoint --------------------------------------------------------------------} --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Check whether the key sets of two +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Check whether the key sets of two -- maps are disjoint (i.e., their 'intersection' is empty). -- -- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True @@ -2467,10 +2491,8 @@ -- | Filter the entries whose keys are missing from the other map -- using some 'Applicative' action. -- --- @ --- filterAMissing f = Merge.Lazy.traverseMaybeMissing $ --- \k x -> (\b -> guard b *> Just x) <$> f k x --- @ +-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $ +-- > \k x -> (\b -> guard b *> Just x) <$> f k x -- -- but this should be a little faster. -- @@ -2745,7 +2767,7 @@ {-------------------------------------------------------------------- Submap --------------------------------------------------------------------} --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -- isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool @@ -2754,7 +2776,7 @@ {-# INLINABLE isSubmapOf #-} #endif -{- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). +{- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when applied to their respective values. For example, the following @@ -2803,7 +2825,7 @@ {-# INLINABLE submap' #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Is this a proper submap? (ie. a submap but not equal). +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Is this a proper submap? (ie. a submap but not equal). -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool isProperSubmapOf m1 m2 @@ -2812,7 +2834,7 @@ {-# INLINABLE isProperSubmapOf #-} #endif -{- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Is this a proper submap? (ie. a submap but not equal). +{- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when @keys m1@ and @keys m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when @@ -2899,7 +2921,7 @@ -- -- @ -- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList' --- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k)) +-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k)) -- @ -- -- @since 0.5.8 @@ -2916,7 +2938,7 @@ -- -- @ -- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs) --- spanAntitone p xs = partitionWithKey (\k _ -> p k) xs +-- spanAntitone p xs = partitionWithKey (\\k _ -> p k) xs -- @ -- -- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map @@ -3082,7 +3104,7 @@ #endif -- | \(O(n)\). --- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ +-- @'traverseWithKey' f m == '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. -- @@ -3163,6 +3185,8 @@ -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" +-- +-- Also see the performance note on 'fromListWith'. mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] @@ -3383,7 +3407,7 @@ fromSet _ Set.Tip = Tip fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r) --- | /O(n)/. Build a map from a set of elements contained inside 'Arg's. +-- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. -- -- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")] -- > fromArgSet Data.Set.empty == empty @@ -3408,8 +3432,7 @@ -- If the list contains more than one value for the same key, the last value -- for the key is retained. -- --- If the keys of the list are ordered, linear-time implementation is used, --- with the performance equal to 'fromDistinctAscList'. +-- If the keys of the list are ordered, a linear-time implementation is used. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] @@ -3458,8 +3481,39 @@ -- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty +-- +-- Note the reverse ordering of @"cba"@ in the example. +-- +-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@. +-- +-- === Performance +-- +-- You should ensure that the given @f@ is fast with this order of arguments. +-- +-- Symmetric functions may be slow in one order, and fast in another. +-- For the common case of collecting values of matching keys in a list, as above: +-- +-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument. +-- Thus: +-- +-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast +-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow +-- +-- because they evaluate as, respectively: +-- +-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n) +-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²) +-- +-- Thus, to get good performance with an operation like @(++)@ while also preserving +-- the same order as in the input list, reverse the input: +-- +-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")] +-- +-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in: +-- +-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a fromListWith f xs @@ -3470,9 +3524,11 @@ -- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. -- --- > let f k a1 a2 = (show k) ++ a1 ++ a2 --- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] +-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] -- > fromListWithKey f [] == empty +-- +-- Also see the performance note on 'fromListWith'. fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromListWithKey f xs @@ -3625,6 +3681,8 @@ -- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True -- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False -- +-- Also see the performance note on 'fromListWith'. +-- -- @since 0.5.8 fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a @@ -3642,6 +3700,8 @@ -- > 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 +-- +-- Also see the performance note on 'fromListWith'. fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromAscListWithKey f xs @@ -3670,6 +3730,9 @@ -- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] -- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True -- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False +-- +-- Also see the performance note on 'fromListWith'. + fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromDescListWithKey f xs = fromDistinctDescList (combineEq f xs) @@ -3699,23 +3762,27 @@ -- For some reason, when 'singleton' is used in fromDistinctAscList or in -- create, it is not inlined, so we inline it manually. + +-- See Note [fromDistinctAscList implementation] in Data.Set.Internal. fromDistinctAscList :: [(k,a)] -> Map k a -fromDistinctAscList [] = Tip -fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 +fromDistinctAscList = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada) where - go !_ t [] = t - go s l ((kx, x) : xs) = case create s xs of - (r :*: ys) -> let !t' = link kx x l r - in go (s `shiftL` 1) t' ys + next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a + next (State0 stk) (!kx, x) = fromDistinctAscList_linkTop (Bin 1 kx x Tip Tip) stk + next (State1 l stk) (kx, x) = State0 (Push kx x l stk) +{-# INLINE fromDistinctAscList #-} -- INLINE for fusion - create !_ [] = (Tip :*: []) - create s xs@(x' : xs') - | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs') - | otherwise = case create (s `shiftR` 1) xs of - res@(_ :*: []) -> res - (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of - (r :*: zs) -> (link ky y l r :*: zs) +fromDistinctAscList_linkTop :: Map k a -> Stack k a -> FromDistinctMonoState k a +fromDistinctAscList_linkTop r@(Bin rsz _ _ _ _) (Push kx x l@(Bin lsz _ _ _ _) stk) + | rsz == lsz = fromDistinctAscList_linkTop (bin kx x l r) stk +fromDistinctAscList_linkTop l stk = State1 l stk +{-# INLINABLE fromDistinctAscList_linkTop #-} +fromDistinctAscList_linkAll :: FromDistinctMonoState k a -> Map k a +fromDistinctAscList_linkAll (State0 stk) = foldl'Stack (\r kx x l -> link kx x l r) Tip stk +fromDistinctAscList_linkAll (State1 r0 stk) = foldl'Stack (\r kx x l -> link kx x l r) r0 stk +{-# INLINABLE fromDistinctAscList_linkAll #-} + -- | \(O(n)\). Build a map from a descending list of distinct elements in linear time. -- /The precondition is not checked./ -- @@ -3727,23 +3794,40 @@ -- For some reason, when 'singleton' is used in fromDistinctDescList or in -- create, it is not inlined, so we inline it manually. + +-- See Note [fromDistinctAscList implementation] in Data.Set.Internal. fromDistinctDescList :: [(k,a)] -> Map k a -fromDistinctDescList [] = Tip -fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs0 +fromDistinctDescList = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada) where - go !_ t [] = t - go s r ((kx, x) : xs) = case create s xs of - (l :*: ys) -> let !t' = link kx x l r - in go (s `shiftL` 1) t' ys + next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a + next (State0 stk) (!kx, x) = fromDistinctDescList_linkTop (Bin 1 kx x Tip Tip) stk + next (State1 r stk) (kx, x) = State0 (Push kx x r stk) +{-# INLINE fromDistinctDescList #-} -- INLINE for fusion - create !_ [] = (Tip :*: []) - create s xs@(x' : xs') - | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs') - | otherwise = case create (s `shiftR` 1) xs of - res@(_ :*: []) -> res - (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of - (l :*: zs) -> (link ky y l r :*: zs) +fromDistinctDescList_linkTop :: Map k a -> Stack k a -> FromDistinctMonoState k a +fromDistinctDescList_linkTop l@(Bin lsz _ _ _ _) (Push kx x r@(Bin rsz _ _ _ _) stk) + | lsz == rsz = fromDistinctDescList_linkTop (bin kx x l r) stk +fromDistinctDescList_linkTop r stk = State1 r stk +{-# INLINABLE fromDistinctDescList_linkTop #-} +fromDistinctDescList_linkAll :: FromDistinctMonoState k a -> Map k a +fromDistinctDescList_linkAll (State0 stk) = foldl'Stack (\l kx x r -> link kx x l r) Tip stk +fromDistinctDescList_linkAll (State1 l0 stk) = foldl'Stack (\l kx x r -> link kx x l r) l0 stk +{-# INLINABLE fromDistinctDescList_linkAll #-} + +data FromDistinctMonoState k a + = State0 !(Stack k a) + | State1 !(Map k a) !(Stack k a) + +data Stack k a = Push !k a !(Map k a) !(Stack k a) | Nada + +foldl'Stack :: (b -> k -> a -> Map k a -> b) -> b -> Stack k a -> b +foldl'Stack f = go + where + go !z Nada = z + go z (Push kx x t stk) = go (f z kx x t) stk +{-# INLINE foldl'Stack #-} + {- -- Functions very similar to these were used to implement -- hedge union, intersection, and difference algorithms that we no @@ -3831,7 +3915,7 @@ {-# INLINABLE splitLookup #-} #endif --- | A variant of 'splitLookup' that indicates only whether the +-- | \(O(\log n)\). A variant of 'splitLookup' that indicates only whether the -- key was present, rather than producing its value. This is used to -- implement 'intersection' to avoid allocating unnecessary 'Just' -- constructors. @@ -4254,7 +4338,6 @@ product = foldl' (*) 1 {-# INLINABLE product #-} -#if MIN_VERSION_base(4,10,0) -- | @since 0.6.3.1 instance Bifoldable Map where bifold = go @@ -4275,7 +4358,6 @@ go (Bin 1 k v _ _) = f k `mappend` g v go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r)) {-# INLINE bifoldMap #-} -#endif instance (NFData k, NFData a) => NFData (Map k a) where rnf Tip = () diff --git a/src/Data/Strict/Map/Autogen/Internal/Debug.hs b/src/Data/Strict/Map/Autogen/Internal/Debug.hs --- a/src/Data/Strict/Map/Autogen/Internal/Debug.hs +++ b/src/Data/Strict/Map/Autogen/Internal/Debug.hs @@ -6,7 +6,7 @@ import Data.Strict.Map.Autogen.Internal (Map (..), size, delta) import Control.Monad (guard) --- | \(O(n)\). Show the tree that implements the map. The tree is shown +-- | \(O(n \log n)\). Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. See 'showTreeWith'. showTree :: (Show k,Show a) => Map k a -> String showTree m @@ -15,7 +15,7 @@ showElem k x = show k ++ ":=" ++ show x -{- | \(O(n)\). The expression (@'showTreeWith' showelem hang wide map@) shows +{- | \(O(n \log n)\). The expression (@'showTreeWith' showelem hang wide map@) shows the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown. @@ -91,7 +91,7 @@ showsBars bars = case bars of [] -> id - _ -> showString (concat (reverse (tail bars))) . showString node + _ : tl -> showString (concat (reverse tl)) . showString node node :: String node = "+--" diff --git a/src/Data/Strict/Map/Autogen/Internal/DeprecatedShowTree.hs b/src/Data/Strict/Map/Autogen/Internal/DeprecatedShowTree.hs --- a/src/Data/Strict/Map/Autogen/Internal/DeprecatedShowTree.hs +++ b/src/Data/Strict/Map/Autogen/Internal/DeprecatedShowTree.hs @@ -1,12 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, DataKinds #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE MonoLocalBinds #-} -#endif -#if __GLASGOW_HASKELL__ < 710 --- Why do we need this? Guess it doesn't matter; this is all --- going away soon. -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE CPP, FlexibleContexts, DataKinds, MonoLocalBinds #-} #include "containers.h" diff --git a/src/Data/Strict/Map/Autogen/Strict/Internal.hs b/src/Data/Strict/Map/Autogen/Strict/Internal.hs --- a/src/Data/Strict/Map/Autogen/Strict/Internal.hs +++ b/src/Data/Strict/Map/Autogen/Strict/Internal.hs @@ -308,7 +308,9 @@ , valid ) where -import Prelude hiding (lookup,map,filter,foldr,foldl,null,take,drop,splitAt) +import Data.Strict.ContainersUtils.Autogen.Prelude hiding + (lookup,map,filter,foldr,foldl,foldl',null,take,drop,splitAt) +import Prelude () import Data.Strict.Map.Autogen.Internal ( Map (..) @@ -326,6 +328,12 @@ , filterAMissing , merge , mergeA + , fromDistinctAscList_linkTop + , fromDistinctAscList_linkAll + , fromDistinctDescList_linkTop + , fromDistinctDescList_linkAll + , FromDistinctMonoState (..) + , Stack (..) , (!) , (!?) , (\\) @@ -538,6 +546,8 @@ -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +-- +-- Also see the performance note on 'fromListWith'. insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith = go @@ -582,6 +592,8 @@ -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +-- +-- Also see the performance note on 'fromListWith'. -- See Map.Internal.Note: Type of local 'go' function insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a @@ -637,6 +649,8 @@ -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +-- +-- Also see the performance note on 'fromListWith'. -- See Map.Internal.Note: Type of local 'go' function insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a @@ -972,9 +986,11 @@ {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------} --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Union with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith _f t1 Tip = t1 @@ -988,11 +1004,13 @@ {-# INLINABLE unionWith #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). -- Union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +-- +-- Also see the performance note on 'fromListWith'. unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a unionWithKey _f t1 Tip = t1 @@ -1046,7 +1064,7 @@ Intersection --------------------------------------------------------------------} --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -1064,7 +1082,7 @@ {-# INLINABLE intersectionWith #-} #endif --- | \(O\bigl(m \log\bigl(\frac{n+1}{m+1}\bigr)\bigr), \; m \leq n\). Intersection with a combining function. +-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" @@ -1385,7 +1403,7 @@ #endif -- | \(O(n)\). --- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' \`seq\` (k,v')) <$> f k v) ('toList' m)@ +-- @'traverseWithKey' f m == 'fromList' \<$\> 'traverse' (\\(k, v) -> (\v' -> v' \`seq\` (k,v')) \<$\> f k v) ('toList' m)@ -- That is, it behaves much like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value and the values are -- forced before they are installed in the result map. @@ -1450,6 +1468,8 @@ -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" +-- +-- Also see the performance note on 'fromListWith'. mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] @@ -1471,7 +1491,7 @@ fromSet _ Set.Tip = Tip fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r) --- | /O(n)/. Build a map from a set of elements contained inside 'Arg's. +-- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. -- -- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")] -- > fromArgSet Data.Set.empty == empty @@ -1487,8 +1507,7 @@ -- If the list contains more than one value for the same key, the last value -- for the key is retained. -- --- If the keys of the list are ordered, linear-time implementation is used, --- with the performance equal to 'fromDistinctAscList'. +-- If the keys of the list are ordered, a linear-time implementation is used. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] @@ -1537,8 +1556,39 @@ -- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty +-- +-- Note the reverse ordering of @"cba"@ in the example. +-- +-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@. +-- +-- === Performance +-- +-- You should ensure that the given @f@ is fast with this order of arguments. +-- +-- Symmetric functions may be slow in one order, and fast in another. +-- For the common case of collecting values of matching keys in a list, as above: +-- +-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument. +-- Thus: +-- +-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast +-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow +-- +-- because they evaluate as, respectively: +-- +-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n) +-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²) +-- +-- Thus, to get good performance with an operation like @(++)@ while also preserving +-- the same order as in the input list, reverse the input: +-- +-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")] +-- +-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in: +-- +-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a fromListWith f xs @@ -1549,9 +1599,11 @@ -- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. -- --- > let f k a1 a2 = (show k) ++ a1 ++ a2 --- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")] +-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] -- > fromListWithKey f [] == empty +-- +-- Also see the performance note on 'fromListWith'. fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromListWithKey f xs @@ -1608,6 +1660,8 @@ -- > 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 +-- +-- Also see the performance note on 'fromListWith'. fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a fromAscListWith f xs @@ -1622,6 +1676,8 @@ -- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")] -- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True -- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False +-- +-- Also see the performance note on 'fromListWith'. fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a fromDescListWith f xs @@ -1638,6 +1694,8 @@ -- > 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 +-- +-- Also see the performance note on 'fromListWith'. fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromAscListWithKey f xs @@ -1666,6 +1724,8 @@ -- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] -- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True -- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False +-- +-- Also see the performance note on 'fromListWith'. fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromDescListWithKey f xs @@ -1695,23 +1755,15 @@ -- For some reason, when 'singleton' is used in fromDistinctAscList or in -- create, it is not inlined, so we inline it manually. + +-- See Note [fromDistinctAscList implementation] in Data.Set.Internal. fromDistinctAscList :: [(k,a)] -> Map k a -fromDistinctAscList [] = Tip -fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 +fromDistinctAscList = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada) where - go !_ t [] = t - go s l ((kx, x) : xs) = - case create s xs of - (r :*: ys) -> x `seq` let !t' = link kx x l r - in go (s `shiftL` 1) t' ys - - create !_ [] = (Tip :*: []) - create s xs@(x' : xs') - | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs') - | otherwise = case create (s `shiftR` 1) xs of - res@(_ :*: []) -> res - (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of - (r :*: zs) -> y `seq` (link ky y l r :*: zs) + next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a + next (State0 stk) (!kx, !x) = fromDistinctAscList_linkTop (Bin 1 kx x Tip Tip) stk + next (State1 l stk) (kx, x) = State0 (Push kx x l stk) +{-# INLINE fromDistinctAscList #-} -- INLINE for fusion -- | \(O(n)\). Build a map from a descending list of distinct elements in linear time. -- /The precondition is not checked./ @@ -1722,20 +1774,12 @@ -- For some reason, when 'singleton' is used in fromDistinctDescList or in -- create, it is not inlined, so we inline it manually. + +-- See Note [fromDistinctAscList implementation] in Data.Set.Internal. fromDistinctDescList :: [(k,a)] -> Map k a -fromDistinctDescList [] = Tip -fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0 +fromDistinctDescList = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada) where - go !_ t [] = t - go s r ((kx, x) : xs) = - case create s xs of - (l :*: ys) -> x `seq` let !t' = link kx x l r - in go (s `shiftL` 1) t' ys - - create !_ [] = (Tip :*: []) - create s xs@(x' : xs') - | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs') - | otherwise = case create (s `shiftR` 1) xs of - res@(_ :*: []) -> res - (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of - (l :*: zs) -> y `seq` (link ky y l r :*: zs) + next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a + next (State0 stk) (!kx, !x) = fromDistinctDescList_linkTop (Bin 1 kx x Tip Tip) stk + next (State1 r stk) (kx, x) = State0 (Push kx x r stk) +{-# INLINE fromDistinctDescList #-} -- INLINE for fusion diff --git a/src/Data/Strict/Sequence/Autogen.hs b/src/Data/Strict/Sequence/Autogen.hs --- a/src/Data/Strict/Sequence/Autogen.hs +++ b/src/Data/Strict/Sequence/Autogen.hs @@ -249,7 +249,6 @@ import Prelude () #ifdef __HADDOCK_VERSION__ import Control.Monad (Monad (..)) -import Control.Applicative (Applicative (..)) import Data.Functor (Functor (..)) #endif diff --git a/src/Data/Strict/Sequence/Autogen/Internal.hs b/src/Data/Strict/Sequence/Autogen/Internal.hs --- a/src/Data/Strict/Sequence/Autogen/Internal.hs +++ b/src/Data/Strict/Sequence/Autogen/Internal.hs @@ -191,24 +191,25 @@ node3, ) where -import Prelude hiding ( +import Data.Strict.ContainersUtils.Autogen.Prelude hiding ( Functor(..), #if MIN_VERSION_base(4,11,0) (<>), #endif - Applicative, (<$>), foldMap, Monoid, - null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1, + (<$>), Monoid, + null, length, lookup, take, drop, splitAt, scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3, unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all) -import Control.Applicative (Applicative(..), (<$>), (<**>), Alternative, - liftA2, liftA3) +import Prelude () +import Control.Applicative ((<$>), (<**>), Alternative, + liftA3) import qualified Control.Applicative as Applicative import Control.DeepSeq (NFData(rnf)) import Control.Monad (MonadPlus(..)) import Data.Monoid (Monoid(..)) import Data.Functor (Functor(..)) import Data.Strict.ContainersUtils.Autogen.State (State(..), execState) -import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList) +import Data.Foldable (foldr', toList) import qualified Data.Foldable as F import qualified Data.Semigroup as Semigroup @@ -223,6 +224,8 @@ import Data.Data import Data.String (IsString(..)) import qualified Language.Haskell.TH.Syntax as TH +-- See Note [ Template Haskell Dependencies ] +import Language.Haskell.TH () import GHC.Generics (Generic, Generic1) #endif @@ -269,10 +272,8 @@ infixr 5 :<| infixl 5 :|> -#if __GLASGOW_HASKELL__ >= 801 {-# COMPLETE (:<|), Empty #-} {-# COMPLETE (:|>), Empty #-} -#endif -- | A bidirectional pattern synonym matching an empty sequence. -- @@ -338,7 +339,7 @@ newtype Seq a = Seq (FingerTree (Elem a)) #ifdef __GLASGOW_HASKELL__ --- | @since FIXME +-- | @since 0.6.6 instance TH.Lift a => TH.Lift (Seq a) where # if MIN_VERSION_template_haskell(2,16,0) liftTyped t = [|| coerceFT z ||] @@ -523,9 +524,7 @@ pure = singleton xs *> ys = cycleNTimes (length xs) ys (<*>) = apSeq -#if MIN_VERSION_base(4,10,0) liftA2 = liftA2Seq -#endif xs <* ys = beforeSeq xs ys apSeq :: Seq (a -> b) -> Seq a -> Seq b @@ -1008,6 +1007,7 @@ -- | @since 0.6.1 deriving instance Generic (FingerTree a) +-- | @since 0.6.6 deriving instance TH.Lift a => TH.Lift (FingerTree a) #endif @@ -1201,6 +1201,7 @@ -- | @since 0.6.1 deriving instance Generic (Digit a) +-- | @since 0.6.6 deriving instance TH.Lift a => TH.Lift (Digit a) #endif @@ -1304,6 +1305,7 @@ -- | @since 0.6.1 deriving instance Generic (Node a) +-- | @since 0.6.6 deriving instance TH.Lift a => TH.Lift (Node a) #endif @@ -1702,7 +1704,8 @@ | otherwise = error "replicateA takes a nonnegative integer argument" {-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-} --- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'. +-- | 'replicateM' is the @Seq@ counterpart of +-- @Control.Monad.'Control.Monad.replicateM'@. -- -- > replicateM n x = sequence (replicate n x) -- @@ -1879,7 +1882,8 @@ (><) :: Seq a -> Seq a -> Seq a Seq xs >< Seq ys = Seq (appendTree0 xs ys) --- The appendTree/addDigits gunk below is machine generated +-- The appendTree/addDigits gunk below was originally machine generated via mkappend.hs, +-- but has since been manually edited to include strictness annotations. appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) appendTree0 EmptyT xs = @@ -2171,7 +2175,7 @@ -- | @since 0.5.8 deriving instance Generic (ViewL a) --- | @since FIXME +-- | @since 0.6.6 deriving instance TH.Lift a => TH.Lift (ViewL a) #endif @@ -2238,7 +2242,7 @@ -- | @since 0.5.8 deriving instance Generic (ViewR a) --- | @since FIXME +-- | @since 0.6.6 deriving instance TH.Lift a => TH.Lift (ViewR a) #endif @@ -4637,6 +4641,8 @@ -- | @ 'mzipWith' = 'zipWith' @ -- -- @ 'munzip' = 'unzip' @ +-- +-- @since 0.5.10.1 instance MonadZip Seq where mzipWith = zipWith munzip = unzip diff --git a/src/Data/Strict/Vector/Autogen.hs b/src/Data/Strict/Vector/Autogen.hs --- a/src/Data/Strict/Vector/Autogen.hs +++ b/src/Data/Strict/Vector/Autogen.hs @@ -125,7 +125,7 @@ partition, unstablePartition, partitionWith, span, break, groupBy, group, -- ** Searching - elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, + elem, notElem, find, findIndex, findIndexR, findIndices, elemIndex, elemIndices, -- * Folding foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', @@ -187,6 +187,9 @@ ) import Control.Monad ( MonadPlus(..), liftM, ap ) +#if !MIN_VERSION_base(4,13,0) +import Control.Monad (fail) +#endif import Control.Monad.ST ( ST, runST ) import Control.Monad.Primitive import qualified Control.Monad.Fail as Fail @@ -194,19 +197,10 @@ import Control.Monad.Zip import Data.Function ( fix ) -import Prelude hiding ( length, null, - replicate, (++), concat, - head, last, - init, tail, take, drop, splitAt, reverse, - map, concatMap, - zipWith, zipWith3, zip, zip3, unzip, unzip3, - filter, takeWhile, dropWhile, span, break, - elem, notElem, - foldl, foldl1, foldr, foldr1, foldMap, - all, any, and, or, sum, product, minimum, maximum, - scanl, scanl1, scanr, scanr1, - enumFromTo, enumFromThenTo, - mapM, mapM_, sequence, sequence_ ) +import Prelude + ( Eq, Ord, Num, Enum, Monoid, Functor, Monad, Show, Bool, Ordering(..), Int, Maybe, Either + , compare, mempty, mappend, mconcat, return, showsPrec, fmap, otherwise, id, flip, const, seq + , (>>=), (+), (-), (<), (<=), (>), (>=), (==), (/=), (&&), (.), ($) ) import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) import Data.Typeable ( Typeable ) @@ -1068,13 +1062,16 @@ -- Safe destructive updates -- ------------------------ --- | Apply a destructive operation to a vector. The operation will be +-- | Apply a destructive operation to a vector. The operation may be -- performed in place if it is safe to do so and will modify a copy of the --- vector otherwise. +-- vector otherwise (see 'Data.Strict.Vector.Autogen.Generic.New.New' for details). -- --- @ --- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> --- @ +-- ==== __Examples__ +-- +-- >>> import qualified Data.Strict.Vector.Autogen as V +-- >>> import qualified Data.Strict.Vector.Autogen.Mutable as MV +-- >>> V.modify (\v -> MV.write v 0 'x') $ V.replicate 4 'a' +-- "xaaa" modify :: (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a {-# INLINE modify #-} modify p = G.modify p @@ -1483,6 +1480,14 @@ {-# INLINE findIndex #-} findIndex = G.findIndex +-- | /O(n)/ Yield 'Just' the index of the /last/ element matching the predicate +-- or 'Nothing' if no such element exists. +-- +-- Does not fuse. +findIndexR :: (a -> Bool) -> Vector a -> Maybe Int +{-# INLINE findIndexR #-} +findIndexR = G.findIndexR + -- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending -- order. findIndices :: (a -> Bool) -> Vector a -> Vector Int @@ -2250,3 +2255,4 @@ -- $setup -- >>> :set -Wno-type-defaults +-- >>> import Prelude (Char, String, Bool(True, False), min, max, fst, even, undefined) diff --git a/src/Data/Strict/Vector/Autogen/Internal/Check.hs b/src/Data/Strict/Vector/Autogen/Internal/Check.hs --- a/src/Data/Strict/Vector/Autogen/Internal/Check.hs +++ b/src/Data/Strict/Vector/Autogen/Internal/Check.hs @@ -27,7 +27,10 @@ ) where import GHC.Exts (Int(..), Int#) -import Prelude hiding( error, (&&), (||), not ) +import Prelude + ( Eq, Bool(..), Word, String + , otherwise, fromIntegral, show, unlines + , (-), (<), (<=), (>=), ($), (++) ) import qualified Prelude as P import GHC.Stack (HasCallStack) diff --git a/src/Data/Strict/Vector/Autogen/Mutable.hs b/src/Data/Strict/Vector/Autogen/Mutable.hs --- a/src/Data/Strict/Vector/Autogen/Mutable.hs +++ b/src/Data/Strict/Vector/Autogen/Mutable.hs @@ -76,8 +76,10 @@ import Data.Primitive.Array import Control.Monad.Primitive -import Prelude hiding ( length, null, replicate, reverse, read, - take, drop, splitAt, init, tail, foldr, foldl, mapM_ ) +import Prelude + ( Ord, Monad, Bool, Ordering(..), Int, Maybe + , compare, return, otherwise, error + , (>>=), (+), (-), (*), (<), (>), (>=), (&&), (||), ($), (>>) ) import Data.Typeable ( Typeable ) @@ -742,3 +744,6 @@ toMutableArray :: PrimMonad m => MVector (PrimState m) a -> m (MutableArray (PrimState m) a) {-# INLINE toMutableArray #-} toMutableArray (MVector offset size marr) = cloneMutableArray marr offset size + +-- $setup +-- >>> import Prelude (Integer) diff --git a/strict-containers.cabal b/strict-containers.cabal --- a/strict-containers.cabal +++ b/strict-containers.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: strict-containers -Version: 0.2 +Version: 0.2.1 Synopsis: Strict containers. Category: Data, Data Structures Description: @@ -39,9 +39,9 @@ . -- generated list for versions -- DO NOT EDIT below, AUTOGEN versions - * containers v0.6.6 - * unordered-containers v0.2.19.1 - * vector vector-0.13.0.0 + * containers v0.7 + * unordered-containers v0.2.20 + * vector vector-0.13.1.0 -- DO NOT EDIT above, AUTOGEN versions License: BSD-3-Clause License-File: LICENSE @@ -53,8 +53,8 @@ CHANGELOG.md -- generated list for includes -- DO NOT EDIT below, AUTOGEN includes - include/vector.h include/containers.h + include/vector.h -- DO NOT EDIT above, AUTOGEN includes tested-with: GHC ==8.2.2 @@ -63,8 +63,11 @@ || ==8.8.4 || ==8.10.7 || ==9.0.2 - || ==9.2.4 - || ==9.4.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.5 + || ==9.8.2 + || ==9.10.1 library default-language: Haskell2010 @@ -75,13 +78,13 @@ base >= 4.5.0.0 && < 5 , array >= 0.4.0.0 , binary >= 0.8.4.1 && < 0.9 - , containers >= 0.6.6 && < 0.7 - , deepseq >= 1.2 && < 1.5 + , containers >= 0.6.6 && < 0.8 + , deepseq >= 1.2 && < 1.6 , indexed-traversable >= 0.1.1 && < 0.2 - , hashable >= 1.2.7.0 && < 1.5 - , primitive >= 0.6.4.0 && < 0.8 + , hashable >= 1.2.7.0 && < 1.6 + , primitive >= 0.6.4.0 && < 0.10 , unordered-containers >= 0.2.19.1 && < 0.3 - , strict >= 0.4 && < 0.5 + , strict >= 0.4 && < 0.6 , template-haskell , vector >= 0.13.0.0 && < 0.14 , vector-binary-instances >= 0.2.2.0 && < 0.3 @@ -91,35 +94,36 @@ Data.Strict.HashMap.Internal -- generated list for HashMap -- DO NOT EDIT below, AUTOGEN HashMap - Data.Strict.HashMap.Autogen.Strict Data.Strict.HashMap.Autogen.Internal + Data.Strict.HashMap.Autogen.Internal.List Data.Strict.HashMap.Autogen.Internal.Array + Data.Strict.HashMap.Autogen.Internal.Debug Data.Strict.HashMap.Autogen.Internal.Strict - Data.Strict.HashMap.Autogen.Internal.List + Data.Strict.HashMap.Autogen.Strict -- DO NOT EDIT above, AUTOGEN HashMap Data.Strict.HashSet Data.Strict.IntMap Data.Strict.IntMap.Internal -- generated list for IntMap -- DO NOT EDIT below, AUTOGEN IntMap - Data.Strict.IntMap.Autogen.Strict - Data.Strict.IntMap.Autogen.Internal - Data.Strict.IntMap.Autogen.Merge.Strict Data.Strict.IntMap.Autogen.Strict.Internal - Data.Strict.IntMap.Autogen.Internal.Debug + Data.Strict.IntMap.Autogen.Internal Data.Strict.IntMap.Autogen.Internal.DeprecatedDebug + Data.Strict.IntMap.Autogen.Internal.Debug + Data.Strict.IntMap.Autogen.Strict + Data.Strict.IntMap.Autogen.Merge.Strict -- DO NOT EDIT above, AUTOGEN IntMap Data.Strict.IntSet Data.Strict.Map Data.Strict.Map.Internal -- generated list for Map -- DO NOT EDIT below, AUTOGEN Map - Data.Strict.Map.Autogen.Strict - Data.Strict.Map.Autogen.Internal - Data.Strict.Map.Autogen.Merge.Strict Data.Strict.Map.Autogen.Strict.Internal + Data.Strict.Map.Autogen.Internal Data.Strict.Map.Autogen.Internal.Debug Data.Strict.Map.Autogen.Internal.DeprecatedShowTree + Data.Strict.Map.Autogen.Strict + Data.Strict.Map.Autogen.Merge.Strict -- DO NOT EDIT above, AUTOGEN Map Data.Strict.Sequence Data.Strict.Sequence.Internal @@ -132,22 +136,23 @@ Data.Strict.Set -- generated list for ContainersUtils -- DO NOT EDIT below, AUTOGEN ContainersUtils - Data.Strict.ContainersUtils.Autogen.Coercions - Data.Strict.ContainersUtils.Autogen.BitUtil - Data.Strict.ContainersUtils.Autogen.StrictPair - Data.Strict.ContainersUtils.Autogen.StrictMaybe Data.Strict.ContainersUtils.Autogen.PtrEquality - Data.Strict.ContainersUtils.Autogen.State Data.Strict.ContainersUtils.Autogen.BitQueue Data.Strict.ContainersUtils.Autogen.TypeError + Data.Strict.ContainersUtils.Autogen.StrictMaybe + Data.Strict.ContainersUtils.Autogen.StrictPair + Data.Strict.ContainersUtils.Autogen.State + Data.Strict.ContainersUtils.Autogen.Prelude + Data.Strict.ContainersUtils.Autogen.BitUtil + Data.Strict.ContainersUtils.Autogen.Coercions -- DO NOT EDIT above, AUTOGEN ContainersUtils Data.Strict.Vector Data.Strict.Vector.Internal -- generated list for Vector -- DO NOT EDIT below, AUTOGEN Vector Data.Strict.Vector.Autogen - Data.Strict.Vector.Autogen.Mutable Data.Strict.Vector.Autogen.Internal.Check + Data.Strict.Vector.Autogen.Mutable -- DO NOT EDIT above, AUTOGEN Vector include-dirs: include @@ -157,8 +162,8 @@ common containers-deps build-depends: array >=0.4.0.0 - , base >=4.9.1 && <5 - , deepseq >=1.2 && <1.5 + , base >=4.10 && <5 + , deepseq >=1.2 && <1.6 , template-haskell common containers-test-deps diff --git a/tests/Tests/Bundle.hs b/tests/Tests/Bundle.hs --- a/tests/Tests/Bundle.hs +++ b/tests/Tests/Bundle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} module Tests.Bundle ( tests ) where import Boilerplater diff --git a/tests/Tests/Vector/Property.hs b/tests/Tests/Vector/Property.hs --- a/tests/Tests/Vector/Property.hs +++ b/tests/Tests/Vector/Property.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} module Tests.Vector.Property ( CommonContext , VanillaContext @@ -31,6 +32,7 @@ import Control.Monad.ST import qualified Data.Traversable as T (Traversable(..)) import Data.Orphans () +import Data.Maybe import Data.Foldable (foldrM) import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as MV diff --git a/tests/Utilities.hs b/tests/Utilities.hs --- a/tests/Utilities.hs +++ b/tests/Utilities.hs @@ -1,11 +1,15 @@ +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} module Utilities where import Test.QuickCheck import Data.Foldable -import qualified Data.Strict.Vector as DV +import Data.Bifunctor +import qualified Data.Strict.Vector as DSV +import qualified Data.Vector as DV import qualified Data.Vector.Generic as DVG import qualified Data.Vector.Primitive as DVP import qualified Data.Vector.Storable as DVS @@ -14,7 +18,6 @@ import Control.Monad (foldM, foldM_, zipWithM, zipWithM_) import Control.Monad.Trans.Writer -import Data.Function (on) import Data.Functor.Identity import Data.List ( sortBy ) import Data.Maybe (catMaybes) @@ -67,68 +70,67 @@ unmodel :: Model a -> a type EqTest a + type instance EqTest a = Property equal :: a -> a -> EqTest a + default equal :: (Eq a, EqTest a ~ Property) => a -> a -> EqTest a + equal x y = property (x == y) + instance (Eq a, TestData a) => TestData (S.Bundle v a) where type Model (S.Bundle v a) = [Model a] model = map model . S.toList unmodel = S.fromList . map unmodel - type EqTest (S.Bundle v a) = Property - equal x y = property (x == y) - instance (Eq a, TestData a) => TestData (DV.Vector a) where type Model (DV.Vector a) = [Model a] model = map model . DV.toList unmodel = DV.fromList . map unmodel - type EqTest (DV.Vector a) = Property - equal x y = property (x == y) - instance (Eq a, DVP.Prim a, TestData a) => TestData (DVP.Vector a) where type Model (DVP.Vector a) = [Model a] model = map model . DVP.toList unmodel = DVP.fromList . map unmodel - type EqTest (DVP.Vector a) = Property - equal x y = property (x == y) - instance (Eq a, DVS.Storable a, TestData a) => TestData (DVS.Vector a) where type Model (DVS.Vector a) = [Model a] model = map model . DVS.toList unmodel = DVS.fromList . map unmodel - type EqTest (DVS.Vector a) = Property - equal x y = property (x == y) - instance (Eq a, DVU.Unbox a, TestData a) => TestData (DVU.Vector a) where type Model (DVU.Vector a) = [Model a] model = map model . DVU.toList unmodel = DVU.fromList . map unmodel - type EqTest (DVU.Vector a) = Property - equal x y = property (x == y) +instance (Eq a, TestData a) => TestData (DSV.Vector a) where + type Model (DSV.Vector a) = [Model a] + model = map model . DSV.toList + unmodel = DSV.fromList . map unmodel #define id_TestData(ty) \ instance TestData ty where { \ type Model ty = ty; \ model = id; \ - unmodel = id; \ - \ - type EqTest ty = Property; \ - equal x y = property (x == y) } + unmodel = id } \ id_TestData(()) id_TestData(Bool) id_TestData(Int) -id_TestData(Float) -id_TestData(Double) id_TestData(Ordering) -bimapEither :: (a -> b) -> (c -> d) -> Either a c -> Either b d -bimapEither f _ (Left a) = Left (f a) -bimapEither _ g (Right c) = Right (g c) +instance TestData Float where + type Model Float = Float + model = id + unmodel = id + equal x y = property (x == y || (isNaN x && isNaN y)) + +instance TestData Double where + type Model Double = Double + model = id + unmodel = id + + equal x y = property (x == y || (isNaN x && isNaN y)) + -- Functorish models -- All of these need UndecidableInstances although they are actually well founded. Oh well. instance (Eq a, TestData a) => TestData (Maybe a) where @@ -136,57 +138,36 @@ model = fmap model unmodel = fmap unmodel - type EqTest (Maybe a) = Property - equal x y = property (x == y) - instance (Eq a, TestData a, Eq b, TestData b) => TestData (Either a b) where type Model (Either a b) = Either (Model a) (Model b) - model = bimapEither model model - unmodel = bimapEither unmodel unmodel - - type EqTest (Either a b) = Property - equal x y = property (x == y) + model = bimap model model + unmodel = bimap unmodel unmodel instance (Eq a, TestData a) => TestData [a] where type Model [a] = [Model a] model = fmap model unmodel = fmap unmodel - type EqTest [a] = Property - equal x y = property (x == y) - instance (Eq a, TestData a) => TestData (Identity a) where type Model (Identity a) = Identity (Model a) model = fmap model unmodel = fmap unmodel - type EqTest (Identity a) = Property - equal = (property .) . on (==) runIdentity - instance (Eq a, TestData a, Eq b, TestData b, Monoid a) => TestData (Writer a b) where type Model (Writer a b) = Writer (Model a) (Model b) model = mapWriter model unmodel = mapWriter unmodel - type EqTest (Writer a b) = Property - equal = (property .) . on (==) runWriter - instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where type Model (a,b) = (Model a, Model b) model (a,b) = (model a, model b) unmodel (a,b) = (unmodel a, unmodel b) - type EqTest (a,b) = Property - equal x y = property (x == y) - instance (Eq a, Eq b, Eq c, TestData a, TestData b, TestData c) => TestData (a,b,c) where type Model (a,b,c) = (Model a, Model b, Model c) model (a,b,c) = (model a, model b, model c) unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c) - type EqTest (a,b,c) = Property - equal x y = property (x == y) - instance (Arbitrary a, Show a, TestData a, TestData b) => TestData (a -> b) where type Model (a -> b) = Model a -> Model b model f = model . f . unmodel @@ -312,9 +293,6 @@ ifilter :: (Int -> a -> Bool) -> [a] -> [a] ifilter f = map snd . withIndexFirst filter f -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe f = catMaybes . map f - imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b] imapMaybe f = catMaybes . withIndexFirst map f @@ -374,3 +352,9 @@ | ours >= 0 , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) | otherwise = Nothing + +instance Arbitrary a => Arbitrary (DSV.Vector a) where + arbitrary = fmap DSV.fromList arbitrary + +instance CoArbitrary a => CoArbitrary (DSV.Vector a) where + coarbitrary = coarbitrary . DSV.toList diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -21,7 +21,7 @@ import Data.Foldable (foldMap) import Data.Function import Data.Traversable (Traversable(traverse), foldMapDefault) -import Prelude hiding (lookup, null, map, filter, foldr, foldl) +import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl') import qualified Prelude (map) import Data.List (nub,sort) @@ -180,10 +180,14 @@ , testProperty "deleteMax" prop_deleteMaxModel , testProperty "filter" prop_filter , testProperty "partition" prop_partition + , testProperty "takeWhileAntitone" prop_takeWhileAntitone + , testProperty "dropWhileAntitone" prop_dropWhileAntitone + , testProperty "spanAntitone" prop_spanAntitone , testProperty "map" prop_map , testProperty "fmap" prop_fmap , testProperty "mapkeys" prop_mapkeys , testProperty "split" prop_splitModel + , testProperty "splitLookup" prop_splitLookup , testProperty "splitRoot" prop_splitRoot , testProperty "foldr" prop_foldr , testProperty "foldr'" prop_foldr' @@ -1469,6 +1473,26 @@ m === let (a,b) = (List.partition (apply p . snd) xs) in (fromList a, fromList b) +prop_takeWhileAntitone :: Int -> [(Int, Int)] -> Property +prop_takeWhileAntitone x ys = + let l = takeWhileAntitone ( [(Int, Int)] -> Property +prop_dropWhileAntitone x ys = + let r = dropWhileAntitone (=x) . fst) ys) + +prop_spanAntitone :: Int -> [(Int, Int)] -> Property +prop_spanAntitone x ys = + let (l, r) = spanAntitone (=x) . fst) ys) + prop_map :: Fun Int Int -> [(Int, Int)] -> Property prop_map f ys = length ys > 0 ==> let xs = List.nubBy ((==) `on` fst) ys @@ -1495,6 +1519,16 @@ valid r .&&. toAscList l === sort [(k, v) | (k,v) <- xs, k < n] .&&. toAscList r === sort [(k, v) | (k,v) <- xs, k > n] + +prop_splitLookup :: Int -> [(Int, Int)] -> Property +prop_splitLookup n ys = + let xs = List.nubBy ((==) `on` fst) ys + (l, x, r) = splitLookup n (fromList xs) + in valid l .&&. + valid r .&&. + x === List.lookup n xs .&&. + toAscList l === sort [(k, v) | (k,v) <- xs, k < n] .&&. + toAscList r === sort [(k, v) | (k,v) <- xs, k > n] prop_splitRoot :: IMap -> Bool prop_splitRoot s = loop ls && (s == unions ls) diff --git a/tests/map-properties.hs b/tests/map-properties.hs --- a/tests/map-properties.hs +++ b/tests/map-properties.hs @@ -22,10 +22,8 @@ import Data.Semigroup (Arg(..)) import Data.Function import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) import qualified Data.Bifoldable as Bifoldable -#endif -import Prelude hiding (lookup, null, map, filter, foldr, foldl, take, drop, splitAt) +import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl', take, drop, splitAt) import qualified Prelude import Data.List (nub,sort) @@ -187,6 +185,7 @@ , testProperty "mergeWithKey model" prop_mergeWithKeyModel , testProperty "mergeA effects" prop_mergeA_effects , testProperty "fromAscList" prop_ordered + , testProperty "fromDistinctAscList" prop_fromDistinctAscList , testProperty "fromDescList" prop_rev_ordered , testProperty "fromDistinctDescList" prop_fromDistinctDescList , testProperty "fromList then toList" prop_list @@ -232,14 +231,12 @@ , testProperty "foldlWithKey" prop_foldlWithKey , testProperty "foldl'" prop_foldl' , testProperty "foldlWithKey'" prop_foldlWithKey' -#if MIN_VERSION_base(4,10,0) , testProperty "bifold" prop_bifold , testProperty "bifoldMap" prop_bifoldMap , testProperty "bifoldr" prop_bifoldr , testProperty "bifoldr'" prop_bifoldr' , testProperty "bifoldl" prop_bifoldl , testProperty "bifoldl'" prop_bifoldl' -#endif , testProperty "keysSet" prop_keysSet , testProperty "argSet" prop_argSet , testProperty "fromSet" prop_fromSet @@ -1243,10 +1240,13 @@ prop_descList :: [Int] -> Bool prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])]) -prop_fromDistinctDescList :: Int -> [A] -> Property -prop_fromDistinctDescList top lst = valid converted .&&. (toList converted === reverse original) where - original = zip [top, (top-1)..0] lst - converted = fromDistinctDescList original +prop_fromDistinctDescList :: [(Int, A)] -> Property +prop_fromDistinctDescList xs = + valid t .&&. + toList t === nub_sort_xs + where + t = fromDistinctDescList (reverse nub_sort_xs) + nub_sort_xs = List.map List.head $ List.groupBy ((==) `on` fst) $ List.sortBy (comparing fst) xs prop_ascDescList :: [Int] -> Bool prop_ascDescList xs = toAscList m == reverse (toDescList m) @@ -1256,11 +1256,17 @@ prop_fromList xs = case fromList (zip xs xs) of t -> t == fromAscList (zip sort_xs sort_xs) && - t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) && t == List.foldr (uncurry insert) empty (zip xs xs) where sort_xs = sort xs - nub_sort_xs = List.map List.head $ List.group sort_xs +prop_fromDistinctAscList :: [(Int, A)] -> Property +prop_fromDistinctAscList xs = + valid t .&&. + toList t === nub_sort_xs + where + t = fromDistinctAscList nub_sort_xs + nub_sort_xs = List.map List.head $ List.groupBy ((==) `on` fst) $ List.sortBy (comparing fst) xs + ---------------------------------------------------------------- prop_alter :: UMap -> Int -> Bool @@ -1531,7 +1537,6 @@ where c' acc k v = apply c (acc, k, v) -#if MIN_VERSION_base(4,10,0) prop_bifold :: Map Int Int -> Property prop_bifold m = Bifoldable.bifold (mapKeys (:[]) ((:[]) <$> m)) === Foldable.fold ((\(k,v) -> [k,v]) <$> toList m) @@ -1565,7 +1570,6 @@ ck' = curry (apply ck) cv' = curry (apply cv) acc `c'` (k,v) = (acc `ck'` k) `cv'` v -#endif prop_keysSet :: [(Int, Int)] -> Bool prop_keysSet xs = diff --git a/tests/seq-properties.hs b/tests/seq-properties.hs --- a/tests/seq-properties.hs +++ b/tests/seq-properties.hs @@ -30,7 +30,7 @@ import Data.Traversable (Traversable(traverse), sequenceA) import Prelude hiding ( lookup, null, length, take, drop, splitAt, - foldl, foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1, + foldl, foldl', foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1, filter, reverse, replicate, zip, zipWith, zip3, zipWith3, all, sum) import qualified Prelude