Add fromDesc functions for Data.Map

Data/Map/Base.hs

@@ -216,6 +216,10 @@ module Data.Map.Base (
     , fromAscListWith
     , fromAscListWithKey
     , fromDistinctAscList
+    , fromDescList
+    , fromDescListWith
+    , fromDescListWithKey
+    , fromDistinctDescList
 
     -- * Filter
     , filter
@@ -2436,6 +2440,21 @@ fromAscList xs
 {-# INLINABLE fromAscList #-}
 #endif
 
+-- | /O(n)/. Build a map from a descending list in linear time.
+-- /The precondition (input list is descending) is not checked./
+--
+-- > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]
+-- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "b")]
+-- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True
+-- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False
+
+fromDescList :: Eq k => [(k,a)] -> Map k a
+fromDescList xs
+  = fromDescListWithKey (\_ x _ -> x) xs
+#if __GLASGOW_HASKELL__
+{-# INLINABLE fromDescList #-}
+#endif
+
 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
 -- /The precondition (input list is ascending) is not checked./
 --
@@ -2450,6 +2469,20 @@ fromAscListWith f xs
 {-# INLINABLE fromAscListWith #-}
 #endif
 
+-- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.
+-- /The precondition (input list is descending) is not checked./
+--
+-- > 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
+
+fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
+fromDescListWith f xs
+  = fromDescListWithKey (\_ x y -> f x y) xs
+#if __GLASGOW_HASKELL__
+{-# INLINABLE fromDescListWith #-}
+#endif
+
 -- | /O(n)/. Build a map from an ascending list in linear time with a
 -- combining function for equal keys.
 -- /The precondition (input list is ascending) is not checked./
@@ -2478,6 +2511,33 @@ fromAscListWithKey f xs
 {-# INLINABLE fromAscListWithKey #-}
 #endif
 
+-- | /O(n)/. Build a map from a descending list in linear time with a
+-- combining function for equal keys.
+-- /The precondition (input list is descending) is not checked./
+--
+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
+-- > 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
+fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
+fromDescListWithKey f xs
+  = fromDistinctDescList (combineEq f xs)
+  where
+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
+  combineEq _ xs'
+    = case xs' of
+        []     -> []
+        [x]    -> [x]
+        (x:xx) -> combineEq' x xx
+
+  combineEq' z [] = [z]
+  combineEq' z@(kz,zz) (x@(kx,xx):xs')
+    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs'
+    | otherwise = z:combineEq' x xs'
+#if __GLASGOW_HASKELL__
+{-# INLINABLE fromDescListWithKey #-}
+#endif
+
 
 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
 -- /The precondition is not checked./
@@ -2504,6 +2564,30 @@ fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
                       (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
                         (r, zs) -> (link ky y l r, zs)
 
+-- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
+-- /The precondition is not checked./
+--
+-- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]
+-- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True
+-- > valid (fromDistinctDescList [(5,"a"), (5,"b"), (3,"b")]) == False
+
+-- For some reason, when 'singleton' is used in fromDistinctDescList or in
+-- create, it is not inlined, so we inline it manually.
+fromDistinctDescList :: [(k,a)] -> Map k a
+fromDistinctDescList [] = Tip
+fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs0
+  where
+     go !_ t [] = t
+     go s r ((kx, x) : xs) = case create s xs of
+                               (l, ys) -> go (s `shiftL` 1) (link kx x l r) ys
+
+     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)
 
 {--------------------------------------------------------------------
   Utility functions that return sub-ranges of the original

Data/Map/Lazy.hs

@@ -165,6 +165,10 @@ module Data.Map.Lazy (
     , fromAscListWith
     , fromAscListWithKey
     , fromDistinctAscList
+    , fromDescList
+    , fromDescListWith
+    , fromDescListWithKey
+    , fromDistinctDescList
 
     -- * Filter
     , M.filter

Data/Map/Strict.hs

@@ -173,6 +173,10 @@ module Data.Map.Strict
     , fromAscListWith
     , fromAscListWithKey
     , fromDistinctAscList
+    , fromDescList
+    , fromDescListWith
+    , fromDescListWithKey
+    , fromDistinctDescList
 
     -- * Filter
     , filter
@@ -268,6 +272,10 @@ import Data.Map.Base hiding
     , fromAscListWith
     , fromAscListWithKey
     , fromDistinctAscList
+    , fromDescList
+    , fromDescListWith
+    , fromDescListWithKey
+    , fromDistinctDescList
     , mapMaybe
     , mapMaybeWithKey
     , mapEither
@@ -1215,25 +1223,43 @@ fromListWithKey f xs
 {--------------------------------------------------------------------
   Building trees from ascending/descending lists can be done in linear time.
 
-  Note that if [xs] is ascending that:
+  Note that if [xs] is ascending then:
     fromAscList xs       == fromList xs
     fromAscListWith f xs == fromListWith f xs
+
+  If [xs] is descending then:
+    fromDescList xs       == fromList xs
+    fromDescListWith f xs == fromListWith f xs
 --------------------------------------------------------------------}
+
 -- | /O(n)/. Build a map from an ascending list in linear time.
 -- /The precondition (input list is ascending) is not checked./
 --
 -- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]
 -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
 -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
 -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
-
 fromAscList :: Eq k => [(k,a)] -> Map k a
 fromAscList xs
   = fromAscListWithKey (\_ x _ -> x) xs
 #if __GLASGOW_HASKELL__
 {-# INLINABLE fromAscList #-}
 #endif
 
+-- | /O(n)/. Build a map from a descending list in linear time.
+-- /The precondition (input list is descending) is not checked./
+--
+-- > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]
+-- > fromDescList [(5,"a"), (5,"b"), (3,"a")] == fromList [(3, "b"), (5, "b")]
+-- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True
+-- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False
+fromDescList :: Eq k => [(k,a)] -> Map k a
+fromDescList xs
+  = fromDescListWithKey (\_ x _ -> x) xs
+#if __GLASGOW_HASKELL__
+{-# INLINABLE fromDescList #-}
+#endif
+
 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
 -- /The precondition (input list is ascending) is not checked./
 --
@@ -1248,6 +1274,20 @@ fromAscListWith f xs
 {-# INLINABLE fromAscListWith #-}
 #endif
 
+-- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.
+-- /The precondition (input list is descending) is not checked./
+--
+-- > 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
+
+fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
+fromDescListWith f xs
+  = fromDescListWithKey (\_ x y -> f x y) xs
+#if __GLASGOW_HASKELL__
+{-# INLINABLE fromDescListWith #-}
+#endif
+
 -- | /O(n)/. Build a map from an ascending list in linear time with a
 -- combining function for equal keys.
 -- /The precondition (input list is ascending) is not checked./
@@ -1276,6 +1316,34 @@ fromAscListWithKey f xs
 {-# INLINABLE fromAscListWithKey #-}
 #endif
 
+-- | /O(n)/. Build a map from a descending list in linear time with a
+-- combining function for equal keys.
+-- /The precondition (input list is descending) is not checked./
+--
+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
+-- > 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
+
+fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
+fromDescListWithKey f xs
+  = fromDistinctDescList (combineEq f xs)
+  where
+  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
+  combineEq _ xs'
+    = case xs' of
+        []     -> []
+        [x]    -> [x]
+        (x:xx) -> combineEq' x xx
+
+  combineEq' z [] = [z]
+  combineEq' z@(kz,zz) (x@(kx,xx):xs')
+    | kx==kz    = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'
+    | otherwise = z:combineEq' x xs'
+#if __GLASGOW_HASKELL__
+{-# INLINABLE fromDescListWithKey #-}
+#endif
+
 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
 -- /The precondition is not checked./
 --
@@ -1300,3 +1368,28 @@ fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip T
                       res@(_, []) -> res
                       (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
                         (r, zs) -> y `seq` (link ky y l r, zs)
+
+-- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
+-- /The precondition is not checked./
+--
+-- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]
+-- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True
+-- > valid (fromDistinctDescList [(5,"a"), (3,"b"), (3,"a")]) == False
+
+-- For some reason, when 'singleton' is used in fromDistinctDescList or in
+-- create, it is not inlined, so we inline it manually.
+fromDistinctDescList :: [(k,a)] -> Map k a
+fromDistinctDescList [] = Tip
+fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
+  where
+    go !_ t [] = t
+    go s r ((kx, x) : xs) = case create s xs of
+                              (l, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) 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)

changelog.md

@@ -25,6 +25,9 @@
 
   * Add `alterF` for `Data.Map` and `Data.IntMap`.
 
+  * Add `fromDescList`, `fromDescListWith`, `fromDescListWithKey`,
+    and `fromDistinctDescList` to `Data.Map`.
+
   * Add `Empty`, `:<|`, and `:|>` pattern synonyms for `Data.Sequence`.
 
   * Add `adjust'`, `(!?)`, `lookup`, `chunksOf`, `cycleTaking`, `insertAt`, `deleteAt`, `intersperse`,

tests/map-properties.hs

@@ -25,6 +25,7 @@ import Test.Framework.Providers.QuickCheck2
 import Test.HUnit hiding (Test, Testable)
 import Test.QuickCheck
 import Test.QuickCheck.Function (Fun (..), apply)
+import Test.QuickCheck.Poly (A)
 
 default (Int)
 
@@ -101,6 +102,7 @@ main = defaultMain
          , testCase "fromAscListWith" test_fromAscListWith
          , testCase "fromAscListWithKey" test_fromAscListWithKey
          , testCase "fromDistinctAscList" test_fromDistinctAscList
+         , testCase "fromDistinctDescList" test_fromDistinctDescList
          , testCase "filter" test_filter
          , testCase "filterWithKey" test_filteWithKey
          , testCase "partition" test_partition
@@ -165,6 +167,8 @@ main = defaultMain
          , testProperty "intersectionWithKeyModel" prop_intersectionWithKeyModel
          , testProperty "mergeWithKey model"   prop_mergeWithKeyModel
          , testProperty "fromAscList"          prop_ordered
+         , testProperty "fromDescList"         prop_rev_ordered
+         , testProperty "fromDistinctDescList" prop_fromDistinctDescList
          , testProperty "fromList then toList" prop_list
          , testProperty "toDescList"           prop_descList
          , testProperty "toAscList+toDescList" prop_ascDescList
@@ -674,6 +678,12 @@ test_fromDistinctAscList = do
     valid (fromDistinctAscList [(3,"b"), (5,"a")])          @?= True
     valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) @?= False
 
+test_fromDistinctDescList :: Assertion
+test_fromDistinctDescList = do
+    fromDistinctDescList [(5,"a"), (3,"b")] @?= fromList [(3, "b"), (5, "a")]
+    valid (fromDistinctDescList [(5,"a"), (3,"b")])          @?= True
+    valid (fromDistinctDescList [(3,"b"), (5,"a"), (5,"b")]) @?= False
+
 ----------------------------------------------------------------
 -- Filter
 
@@ -1044,12 +1054,23 @@ prop_ordered
     let xs = [(x,()) | x <- [0..n::Int]]
     in fromAscList xs == fromList xs
 
+prop_rev_ordered :: Property
+prop_rev_ordered
+  = forAll (choose (5,100)) $ \n ->
+    let xs = [(x,()) | x <- [0..n::Int]]
+    in fromDescList (reverse xs) == fromList xs
+
 prop_list :: [Int] -> Bool
 prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
 
 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_ascDescList :: [Int] -> Bool
 prop_ascDescList xs = toAscList m == reverse (toDescList m)
   where m = fromList $ zip xs $ repeat ()