diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,7 +1,15 @@ +Version 0.4.2: (2010-02-18) + + * Fixed non-productive loop in `unionAll` when applied to an infinite list + of lists. Thanks to Omar Antolín Camarena for reporting the bug and + Heinrich Apfelmus for some useful comments. + + * Added regression test to test suite. + Version 0.4.1: (2010-02-17) * Simplified the implementation of `mergeAll` and `unionAll` thanks - to some pointers by Heinrich Apfelmus + to some pointers by Heinrich Apfelmus. * Minor documentation fixes diff --git a/Data/List/Ordered.hs b/Data/List/Ordered.hs --- a/Data/List/Ordered.hs +++ b/Data/List/Ordered.hs @@ -372,6 +372,7 @@ data People a = VIP a (People a) | Crowd [a] +foldTree f [] = Crowd [] foldTree f xs = loop xs where loop [x] = x @@ -411,9 +412,7 @@ -- | The 'mergeAllBy' function is the non-overloaded variant of the 'mergeAll' function. mergeAllBy :: (a -> a -> Ordering) -> [[a]] -> [a] -mergeAllBy cmp xss = case vips xss of - [] -> [] - xss' -> serve (foldTree merge' xss') +mergeAllBy cmp = serve . foldTree merge' . vips where merge' (VIP x xs) ys = VIP x (merge' xs ys) merge' (Crowd []) ys = ys @@ -450,16 +449,16 @@ -- | The 'unionAllBy' function is the non-overloaded variant of the 'unionAll' function. unionAllBy :: (a -> a -> Ordering) -> [[a]] -> [a] -unionAllBy cmp xss = case vips xss of - [] -> [] - xss' -> serve (foldTree union' xss') +unionAllBy cmp = serve . foldTree union' . vips where - union' (VIP x xs) (VIP y ys) - = case cmp x y of - LT -> VIP x (union' xs (VIP y ys)) - EQ -> VIP x (union' xs ys) - GT -> error "Data.List.Ordered.unionAllBy: the heads of the lists are not sorted" - union' (VIP x xs) (Crowd ys) = VIP x (union' xs (Crowd ys)) + msg = "Data.List.Ordered.unionAllBy: the heads of the lists are not sorted" + union' (VIP x xs) ys + = VIP x $ case ys of + Crowd _ -> union' xs ys + VIP y yt -> case cmp x y of + LT -> union' xs ys + EQ -> union' xs yt + GT -> error msg union' (Crowd []) ys = ys union' (Crowd xs) (Crowd ys) = Crowd (unionBy cmp xs ys) union' xs@(Crowd (x:xt)) ys@(VIP y yt) diff --git a/data-ordlist.cabal b/data-ordlist.cabal --- a/data-ordlist.cabal +++ b/data-ordlist.cabal @@ -1,5 +1,5 @@ Name: data-ordlist -Version: 0.4.1 +Version: 0.4.2 Description: This module provides set and multiset operations on ordered lists. License: BSD3 @@ -22,4 +22,4 @@ source-repository this type: darcs location: http://patch-tag.com/r/lpsmith/data-ordlist/pullrepo - tag: 0.4.1 + tag: 0.4.2 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -111,42 +111,97 @@ prop_mergeAll (HeadOrdered xss) = foldr merge [] xss == mergeAll xss + +approxEq xs ys = take n xs == take n ys + where n = 1000 + +prop_mergeAll_productive = mergeAll [ [n..] | n <- [1..] ] `approxEq` triangle 1 + where + triangle n = replicate n n ++ triangle (n+1) + prop_unionAll :: HeadOrderedLists Int -> Bool prop_unionAll (HeadOrdered xss) = foldr union [] xss == unionAll xss -broken_unionAll :: HeadOrderedLists Int -> Bool -broken_unionAll (HeadOrdered xss) - = foldr union [] xss == foldr union' [] xss - where - union' [] ys = ys - union' (x:xs) ys = x : union xs ys +prop_unionAll_productive = unionAll [ [n..] | n <- [1..] ] `approxEq` [1..] -prop_broken_unionAll = expectFailure broken_unionAll +quickCheckOnce = quickCheckWith (stdArgs {maxSuccess = 1}) main = do - putStr "prop_member: " >> quickCheck prop_member - putStr "prop_insertBag_sort: " >> quickCheck prop_insertBag_sort - putStr "prop_insertSet_nubSort: " >> quickCheck prop_insertSet_nubSort - putStr "prop_nub: " >> quickCheck prop_nub - putStr "prop_nub_isSorted: " >> quickCheck prop_nub_isSorted - putStr "prop_nubSort_isSorted: " >> quickCheck prop_nubSort_isSorted - putStr "prop_isect_subset: " >> quickCheck prop_isect_subset - putStr "prop_isect_examples: " >> quickCheck prop_isect_examples - putStr "prop_union_subset: " >> quickCheck prop_union_subset - putStr "prop_isect_subset_union: " >> quickCheck prop_isect_subset_union - putStr "prop_union_examples: " >> quickCheck prop_union_examples - putStr "prop_minus_subset: " >> quickCheck prop_minus_subset - putStr "prop_minus_examples: " >> quickCheck prop_minus_examples - putStr "prop_xunion_subset_union: " >> quickCheck prop_xunion_subset_union - putStr "prop_merge_xunion_isect_union: " >> quickCheck prop_merge_xunion_isect_union - putStr "prop_merge_union_isect_merge: " >> quickCheck prop_merge_union_isect_merge - putStr "prop_minus_merge_isect_union: " >> quickCheck prop_minus_merge_isect_union - putStr "prop_minus_union_isect_xunion: " >> quickCheck prop_minus_union_isect_xunion - putStr "prop_xunion_examples: " >> quickCheck prop_xunion_examples - putStr "prop_merge_subset: " >> quickCheck prop_merge_subset - putStr "prop_merge_examples: " >> quickCheck prop_merge_examples - putStr "prop_nub_examples: " >> quickCheck prop_nub_examples - putStr "prop_mergeAll: " >> quickCheck prop_mergeAll - putStr "prop_unionAll: " >> quickCheck prop_unionAll - putStr "prop_broken_unionAll: " >> quickCheck prop_broken_unionAll + putStr "\nprop_member\n" + quickCheck prop_member + + putStr "\nprop_insertBag_sort\n" + quickCheck prop_insertBag_sort + + putStr "\nprop_insertSet_nubSort\n" + quickCheck prop_insertSet_nubSort + + putStr "\nprop_nub\n" + quickCheck prop_nub + + putStr "\nprop_nub_isSorted\n" + quickCheck prop_nub_isSorted + + putStr "\nprop_nubSort_isSorted\n" + quickCheck prop_nubSort_isSorted + + putStr "\nprop_isect_subset\n" + quickCheck prop_isect_subset + + putStr "\nprop_isect_examples\n" + quickCheckOnce prop_isect_examples + + putStr "\nprop_union_subset\n" + quickCheck prop_union_subset + + putStr "\nprop_isect_subset_union\n" + quickCheck prop_isect_subset_union + + putStr "\nprop_union_examples\n" + quickCheckOnce prop_union_examples + + putStr "\nprop_minus_subset\n" + quickCheck prop_minus_subset + + putStr "\nprop_minus_examples\n" + quickCheckOnce prop_minus_examples + + putStr "\nprop_xunion_subset_union\n" + quickCheck prop_xunion_subset_union + + putStr "\nprop_merge_xunion_isect_union\n" + quickCheck prop_merge_xunion_isect_union + + putStr "\nprop_merge_union_isect_merge\n" + quickCheck prop_merge_union_isect_merge + + putStr "\nprop_minus_merge_isect_union\n" + quickCheck prop_minus_merge_isect_union + + putStr "\nprop_minus_union_isect_xunion\n" + quickCheck prop_minus_union_isect_xunion + + putStr "\nprop_xunion_examples\n" + quickCheckOnce prop_xunion_examples + + putStr "\nprop_merge_subset\n" + quickCheck prop_merge_subset + + putStr "\nprop_merge_examples\n" + quickCheckOnce prop_merge_examples + + putStr "\nprop_nub_examples\n" + quickCheckOnce prop_nub_examples + + putStr "\nprop_mergeAll\n" + quickCheck prop_mergeAll + + putStr "\nprop_mergeAll_productive\n" + quickCheckOnce prop_mergeAll_productive + + putStr "\nprop_unionAll\n" + quickCheck prop_unionAll + + putStr "\nprop_unionAll_productive\n" + quickCheckOnce prop_unionAll_productive