[commit: packages/containers] cleaned_bugfix394, master, merge-doc-target, merge-fixes-5.9, merge-restrict-fix-5.8, revert-408-bugfix_394: Add fromDescList and fromDistinctDescList (90b3248)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/containers

On branches: cleaned_bugfix394,master,merge-doc-target,merge-fixes-5.9,merge-restrict-fix-5.8,revert-408-bugfix_394
Link       : http://git.haskell.org/packages/containers.git/commitdiff/90b324845fef2cd5986bdeccc819ab92a5e678b6

>---------------------------------------------------------------

commit 90b324845fef2cd5986bdeccc819ab92a5e678b6
Author: David Feuer <David.Feuer at gmail.com>
Date:   Fri Jul 8 14:08:49 2016 -0400

    Add fromDescList and fromDistinctDescList
    
    The set versions are just like the map versions, pretty much.


>---------------------------------------------------------------

90b324845fef2cd5986bdeccc819ab92a5e678b6
 Data/Set.hs             |  2 ++
 Data/Set/Base.hs        | 73 +++++++++++++++++++++++++++++++++++--------------
 changelog.md            |  2 ++
 tests/set-properties.hs | 32 ++++++++++++++++------
 4 files changed, 80 insertions(+), 29 deletions(-)

diff --git a/Data/Set.hs b/Data/Set.hs
index fd8c8b9..297cee2 100644
--- a/Data/Set.hs
+++ b/Data/Set.hs
@@ -129,7 +129,9 @@ module Data.Set (
             , toAscList
             , toDescList
             , fromAscList
+            , fromDescList
             , fromDistinctAscList
+            , fromDistinctDescList
 
             -- * Debugging
             , showTree
diff --git a/Data/Set/Base.hs b/Data/Set/Base.hs
index 92bfc1d..8aabd08 100644
--- a/Data/Set/Base.hs
+++ b/Data/Set/Base.hs
@@ -181,6 +181,8 @@ module Data.Set.Base (
             , toDescList
             , fromAscList
             , fromDistinctAscList
+            , fromDescList
+            , fromDistinctDescList
 
             -- * Debugging
             , showTree
@@ -719,7 +721,7 @@ map f = fromList . List.map f . toList
 
 -- | /O(n)/. The
 --
--- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.
+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.
 -- /The precondition is not checked./
 -- Semi-formally, we have:
 --
@@ -904,24 +906,32 @@ fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0
 -- | /O(n)/. Build a set from an ascending list in linear time.
 -- /The precondition (input list is ascending) is not checked./
 fromAscList :: Eq a => [a] -> Set a
-fromAscList xs
-  = fromDistinctAscList (combineEq xs)
-  where
-  -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
-  combineEq xs'
-    = case xs' of
-        []     -> []
-        [x]    -> [x]
-        (x:xx) -> combineEq' x xx
-
-  combineEq' z [] = [z]
-  combineEq' z (x:xs')
-    | z==x      =   combineEq' z xs'
-    | otherwise = z:combineEq' x xs'
+fromAscList xs = fromDistinctAscList (combineEq xs)
 #if __GLASGOW_HASKELL__
 {-# INLINABLE fromAscList #-}
 #endif
 
+-- | /O(n)/. Build a set from a descending list in linear time.
+-- /The precondition (input list is descending) is not checked./
+fromDescList :: Eq a => [a] -> Set a
+fromDescList xs = fromDistinctDescList (combineEq xs)
+#if __GLASGOW_HASKELL__
+{-# INLINABLE fromDescList #-}
+#endif
+
+-- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
+--
+-- TODO: combineEq allocates an intermediate list. It *should* be better to
+-- make fromAscListBy and fromDescListBy the fundamental operations, and to
+-- implement the rest using those.
+combineEq :: Eq a => [a] -> [a]
+combineEq [] = []
+combineEq (x : xs) = combineEq' x xs
+  where
+    combineEq' z [] = [z]
+    combineEq' z (y:ys)
+      | z == y = combineEq' z ys
+      | otherwise = z : combineEq' y ys
 
 -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
 -- /The precondition (input list is strictly ascending) is not checked./
@@ -934,15 +944,36 @@ fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
   where
     go !_ t [] = t
     go s l (x : xs) = case create s xs of
-                        (r, ys) -> go (s `shiftL` 1) (link x l r) ys
+                        (r :*: ys) -> go (s `shiftL` 1) (link x l r) ys
+
+    create !_ [] = (Tip :*: [])
+    create s xs@(x : xs')
+      | s == 1 = (Bin 1 x Tip Tip :*: xs')
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_ :*: []) -> res
+                      (l :*: (y:ys)) -> case create (s `shiftR` 1) ys of
+                        (r :*: zs) -> (link y l r :*: zs)
+
+-- | /O(n)/. Build a set from a descending list of distinct elements in linear time.
+-- /The precondition (input list is strictly descending) is not checked./
+
+-- For some reason, when 'singleton' is used in fromDistinctDescList or in
+-- create, it is not inlined, so we inline it manually.
+fromDistinctDescList :: [a] -> Set a
+fromDistinctDescList [] = Tip
+fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+  where
+    go !_ t [] = t
+    go s r (x : xs) = case create s xs of
+                        (l :*: ys) -> go (s `shiftL` 1) (link x l r) ys
 
-    create !_ [] = (Tip, [])
+    create !_ [] = (Tip :*: [])
     create s xs@(x : xs')
-      | s == 1 = (Bin 1 x Tip Tip, xs')
+      | s == 1 = (Bin 1 x Tip Tip :*: xs')
       | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_, []) -> res
-                      (l, y:ys) -> case create (s `shiftR` 1) ys of
-                        (r, zs) -> (link y l r, zs)
+                      res@(_ :*: []) -> res
+                      (r :*: (y:ys)) -> case create (s `shiftR` 1) ys of
+                        (l :*: zs) -> (link y l r :*: zs)
 
 {--------------------------------------------------------------------
   Eq converts the set to a list. In a lazy setting, this
diff --git a/changelog.md b/changelog.md
index 79c926b..9f3913e 100644
--- a/changelog.md
+++ b/changelog.md
@@ -28,6 +28,8 @@
   * Add `fromDescList`, `fromDescListWith`, `fromDescListWithKey`,
     and `fromDistinctDescList` to `Data.Map`.
 
+  * Add `fromDescList` and `fromDistinctDescList` to `Data.Set`.
+
   * Add `Empty`, `:<|`, and `:|>` pattern synonyms for `Data.Sequence`.
 
   * Add `adjust'`, `(!?)`, `lookup`, `chunksOf`, `cycleTaking`, `insertAt`, `deleteAt`, `intersperse`,
diff --git a/tests/set-properties.hs b/tests/set-properties.hs
index 694437c..029110d 100644
--- a/tests/set-properties.hs
+++ b/tests/set-properties.hs
@@ -42,10 +42,12 @@ main = defaultMain [ testCase "lookupLT" test_lookupLT
                    , testProperty "prop_IntValid" prop_IntValid
                    , testProperty "prop_Int" prop_Int
                    , testProperty "prop_Ordered" prop_Ordered
+                   , testProperty "prop_DescendingOrdered" prop_DescendingOrdered
                    , testProperty "prop_List" prop_List
                    , testProperty "prop_DescList" prop_DescList
                    , testProperty "prop_AscDescList" prop_AscDescList
                    , testProperty "prop_fromList" prop_fromList
+                   , testProperty "prop_fromListDesc" prop_fromListDesc
                    , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
                    , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
                    , testProperty "prop_isSubsetOf" prop_isSubsetOf
@@ -268,7 +270,12 @@ prop_Int xs ys = toAscList (intersection (fromList xs) (fromList ys))
 prop_Ordered :: Property
 prop_Ordered = forAll (choose (5,100)) $ \n ->
     let xs = [0..n::Int]
-    in fromAscList xs == fromList xs
+    in fromAscList xs === fromList xs
+
+prop_DescendingOrdered :: Property
+prop_DescendingOrdered = forAll (choose (5,100)) $ \n ->
+    let xs = [n,n-1..0::Int]
+    in fromDescList xs === fromList xs
 
 prop_List :: [Int] -> Bool
 prop_List xs = (sort (nub xs) == toList (fromList xs))
@@ -280,13 +287,22 @@ prop_AscDescList :: [Int] -> Bool
 prop_AscDescList xs = toAscList s == reverse (toDescList s)
   where s = fromList xs
 
-prop_fromList :: [Int] -> Bool
-prop_fromList xs
-  = case fromList xs of
-      t -> t == fromAscList sort_xs &&
-           t == fromDistinctAscList nub_sort_xs &&
-           t == List.foldr insert empty xs
-  where sort_xs = sort xs
+prop_fromList :: [Int] -> Property
+prop_fromList xs =
+           t === fromAscList sort_xs .&&.
+           t === fromDistinctAscList nub_sort_xs .&&.
+           t === List.foldr insert empty xs
+  where t = fromList xs
+        sort_xs = sort xs
+        nub_sort_xs = List.map List.head $ List.group sort_xs
+
+prop_fromListDesc :: [Int] -> Property
+prop_fromListDesc xs =
+           t === fromDescList sort_xs .&&.
+           t === fromDistinctDescList nub_sort_xs .&&.
+           t === List.foldr insert empty xs
+  where t = fromList xs
+        sort_xs = reverse (sort xs)
         nub_sort_xs = List.map List.head $ List.group sort_xs
 
 {--------------------------------------------------------------------