From fd598072c0a08dd54e28052e5cb4e1035493b6ec Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Mon, 11 Jan 2021 16:45:51 +0100
Subject: [PATCH] Fix
---
containers/src/Data/IntMap/Internal.hs | 93 ++++----------------------
1 file changed, 13 insertions(+), 80 deletions(-)
diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs
index 0ce33bd5..16aae29b 100644
--- a/containers/src/Data/IntMap/Internal.hs
+++ b/containers/src/Data/IntMap/Internal.hs
@@ -370,7 +370,7 @@ intFromNat = fromIntegral
-- See Note: Order of constructors
data IntMap a
- = NE {-# UNPACK #-} !(IntMapNE a)
+ = NE !(IntMapNE a)
| Nil
-- Fields:
@@ -394,8 +394,11 @@ data IntMapNE a
{-# COMPLETE Nil, Bin, Tip #-}
+pattern Bin :: Prefix -> Mask -> IntMapNE a -> IntMapNE a -> IntMap a
pattern Bin p m l r = NE (Bin' p m l r)
-pattern Tip k a = NE (Tip' k a)
+
+pattern Tip :: Key -> a -> IntMap a
+pattern Tip k a = NE (Tip' k a)
type Prefix = Int
type Mask = Int
@@ -490,7 +493,7 @@ instance Foldable.Foldable IntMap where
toList = elems -- NB: Foldable.toList /= IntMap.toList
{-# INLINE toList #-}
elem !_ Nil = False
- elem x (NE t) = go x t
+ elem x' (NE t) = go x' t
where go !x (Tip' _ y) = x == y
go !x (Bin' _ _ l r) = go x l || go x r
{-# INLINABLE elem #-}
@@ -595,8 +598,8 @@ sizeNE = go 0
-- See Note: Local 'go' functions and capturing]
member :: Key -> IntMap a -> Bool
-member !k Nil = False
-member !k (NE t) = memberNE k t
+member !_ Nil = False
+member k (NE t) = memberNE k t
memberNE :: Key -> IntMapNE a -> Bool
memberNE !k = go
@@ -622,8 +625,8 @@ notMemberNE k m = not $ memberNE k m
-- See Note: Local 'go' functions and capturing]
lookup :: Key -> IntMap a -> Maybe a
-lookup !k Nil = Nothing
lookup !k (NE xs) = lookupNE k xs
+lookup _ Nil = Nothing
lookupNE :: Key -> IntMapNE a -> Maybe a
lookupNE !k = go
@@ -681,8 +684,8 @@ findWithDefaultNE def !k = go
-- See Note: Local 'go' functions and capturing.
lookupLT :: Key -> IntMap a -> Maybe (Key, a)
-lookupLT !k Nil = Nothing
lookupLT !k (NE t) = lookupLTNE k t
+lookupLT _ Nil = Nothing
lookupLTNE :: Key -> IntMapNE a -> Maybe (Key, a)
lookupLTNE !k t = case t of
@@ -713,8 +716,8 @@ lookupLTNE !k t = case t of
-- See Note: Local 'go' functions and capturing.
lookupGT :: Key -> IntMap a -> Maybe (Key, a)
-lookupGT !k Nil = Nothing
lookupGT !k (NE t) = lookupGTNE k t
+lookupGT _ Nil = Nothing
lookupGTNE :: Key -> IntMapNE a -> Maybe (Key, a)
lookupGTNE !k t = case t of
@@ -746,8 +749,8 @@ lookupGTNE !k t = case t of
-- See Note: Local 'go' functions and capturing.
lookupLE :: Key -> IntMap a -> Maybe (Key, a)
-lookupLE !k Nil = Nothing
lookupLE !k (NE t) = lookupLENE k t
+lookupLE _ Nil = Nothing
lookupLENE :: Key -> IntMapNE a -> Maybe (Key, a)
lookupLENE !k t = case t of
@@ -779,8 +782,8 @@ lookupLENE !k t = case t of
-- See Note: Local 'go' functions and capturing.
lookupGE :: Key -> IntMap a -> Maybe (Key, a)
-lookupGE !k Nil = Nothing
lookupGE !k (NE t) = lookupGENE k t
+lookupGE _ Nil = Nothing
lookupGENE :: Key -> IntMapNE a -> Maybe (Key, a)
lookupGENE !k t = case t of
@@ -806,20 +809,12 @@ lookupGENE !k t = case t of
-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is
-- given, it has m > 0.
-unsafeFindMin :: IntMap a -> Maybe (Key, a)
-unsafeFindMin Nil = Nothing
-unsafeFindMin (NE t) = unsafeFindMinNE t
-
unsafeFindMinNE :: IntMapNE a -> Maybe (Key, a)
unsafeFindMinNE (Tip' ky y) = Just (ky, y)
unsafeFindMinNE (Bin' _ _ l _) = unsafeFindMinNE l
-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is
-- given, it has m > 0.
-unsafeFindMax :: IntMap a -> Maybe (Key, a)
-unsafeFindMax Nil = Nothing
-unsafeFindMax (NE t) = unsafeFindMaxNE t
-
unsafeFindMaxNE :: IntMapNE a -> Maybe (Key, a)
unsafeFindMaxNE (Tip' ky y) = Just (ky, y)
unsafeFindMaxNE (Bin' _ _ _ r) = unsafeFindMaxNE r
@@ -1218,10 +1213,6 @@ union :: IntMap a -> IntMap a -> IntMap a
union m1 m2
= mergeWithKey' bin (const . NE) NE NE m1 m2
-unionNE :: IntMapNE a -> IntMapNE a -> IntMapNE a
-unionNE m1 m2
- = mergeWithKeyNE' Bin' const id id m1 m2
-
-- | /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")]
@@ -1318,11 +1309,6 @@ withoutKeysNE t1@(Tip' k1 _) t2
| otherwise = NE t1
-updatePrefix
- :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a
-updatePrefix !kp (NE xs) f = updatePrefixNE kp xs (f . NE)
-updatePrefix _ Nil _ = Nil
-
updatePrefixNE
:: IntSetPrefix -> IntMapNE a -> (IntMapNE a -> IntMap a) -> IntMap a
updatePrefixNE !kp t@(Bin' p m l r) f
@@ -1336,11 +1322,6 @@ updatePrefixNE kp t@(Tip' kx _) f
| otherwise = NE t
-withoutBM :: IntSetBitMap -> IntMap a -> IntMap a
-withoutBM 0 t = t
-withoutBM bm (NE xs) = withoutBMNE bm xs
-withoutBM _ Nil = Nil
-
withoutBMNE :: IntSetBitMap -> IntMapNE a -> IntMap a
withoutBMNE 0 t = NE t
withoutBMNE bm (Bin' p m l r) =
@@ -1412,10 +1393,6 @@ restrictKeysNE t1@(Tip' k1 _) t2
-- | /O(min(n,W))/. Restrict to the sub-map with all keys matching
-- a key prefix.
-lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a
-lookupPrefix !kp (NE xs) = lookupPrefixNE kp xs
-lookupPrefix _ Nil = Nil
-
lookupPrefixNE :: IntSetPrefix -> IntMapNE a -> IntMap a
lookupPrefixNE !kp t@(Bin' p m l r)
| m .&. IntSet.suffixBitMask /= 0 =
@@ -1573,45 +1550,6 @@ mergeWithKey' bin' f g1 g2 = go'
{-# INLINE maybe_link #-}
{-# INLINE mergeWithKey' #-}
-mergeWithKeyNE' :: (Prefix -> Mask -> IntMapNE c -> IntMapNE c -> IntMapNE c)
- -> (IntMapNE a -> IntMapNE b -> IntMapNE c) -> (IntMapNE a -> IntMapNE c) -> (IntMapNE b -> IntMapNE c)
- -> IntMapNE a -> IntMapNE b -> IntMapNE c
-mergeWithKeyNE' bin' f g1 g2 = go
- where
- go t1@(Bin' p1 m1 l1 r1) t2@(Bin' p2 m2 l2 r2)
- | shorter m1 m2 = merge1
- | shorter m2 m1 = merge2
- | p1 == p2 = bin' p1 m1 (go l1 l2) (go r1 r2)
- | otherwise = link p1 (g1 t1) p2 (g2 t2)
- where
- merge1 | nomatch p2 p1 m1 = link p1 (g1 t1) p2 (g2 t2)
- | zero p2 m1 = bin' p1 m1 (go l1 t2) (g1 r1)
- | otherwise = bin' p1 m1 (g1 l1) (go r1 t2)
- merge2 | nomatch p1 p2 m2 = link p1 (g1 t1) p2 (g2 t2)
- | zero p1 m2 = bin' p2 m2 (go t1 l2) (g2 r2)
- | otherwise = bin' p2 m2 (g2 l2) (go t1 r2)
-
- go t1'@(Bin' _ _ _ _) t2'@(Tip' k2' _) = merge0 t2' k2' t1'
- where
- merge0 t2 k2 t1@(Bin' p1 m1 l1 r1)
- | nomatch k2 p1 m1 = link p1 (g1 t1) k2 (g2 t2)
- | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)
- | otherwise = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)
- merge0 t2 k2 t1@(Tip' k1 _)
- | k1 == k2 = f t1 t2
- | otherwise = link k1 (g1 t1) k2 (g2 t2)
-
- go t1'@(Tip' k1' _) t2' = merge0 t1' k1' t2'
- where
- merge0 t1 k1 t2@(Bin' p2 m2 l2 r2)
- | nomatch k1 p2 m2 = link k1 (g1 t1) p2 (g2 t2)
- | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)
- | otherwise = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)
- merge0 t1 k1 t2@(Tip' k2 _)
- | k1 == k2 = f t1 t2
- | otherwise = link k1 (g1 t1) k2 (g2 t2)
-
-{-# INLINE mergeWithKeyNE' #-}
{--------------------------------------------------------------------
mergeA
@@ -2040,11 +1978,6 @@ filterAMissing f = WhenMissing
-- | /O(n)/. Filter keys and values using an 'Applicative' predicate.
-filterWithKeyA
- :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)
-filterWithKeyA _ Nil = pure Nil
-filterWithKeyA f (NE xs) = filterWithKeyANE f xs
-
filterWithKeyANE
:: Applicative f => (Key -> a -> f Bool) -> IntMapNE a -> f (IntMap a)
filterWithKeyANE f t@(Tip' k x) = (bool (NE t) Nil) <$> f k x
--
GitLab