Ticket #4312: containers-set-improvements.patch

File containers-set-improvements.patch, 52.9 KB (added by milan, 4 years ago)
Line 
18 patches for repository http://darcs.haskell.org/packages/containers:
2
3Tue Aug 31 14:40:30 CEST 2010  Johan Tibell <johan.tibell@gmail.com>
4  * Added a test suite for Data.Set
5 
6  Expression coverage: 74%
7
8Tue Aug 31 14:42:25 CEST 2010  Johan Tibell <johan.tibell@gmail.com>
9  * Added benchmarks for Data.Set
10
11Tue Aug 31 14:43:52 CEST 2010  Johan Tibell <johan.tibell@gmail.com>
12  * Improved performance of Data.Set
13 
14  Performance improvements are due to manually applying the
15  worker/wrapper transformation and strictifying the keys.
16 
17  Average speed-up is 32% on a 2GHz Core 2 Duo on OS X 10.5.8
18
19Mon Sep 13 18:51:32 CEST 2010  Milan Straka <fox@ucw.cz>
20  * Make the Set store the elements evaluated (bang added).
21
22Tue Sep 14 15:57:25 CEST 2010  Milan Straka <fox@ucw.cz>
23  * Improve performance of Data.Set union and difference operations.
24 
25  Use datatype storing evaluated bound instead of high-order functions.
26  The improvements are over 25% for both union and difference (GHC 6.12.1).
27
28Tue Sep 14 16:04:17 CEST 2010  Milan Straka <fox@ucw.cz>
29  * Improve the performance of Data.Set balance function.
30 
31  The balance function is now one monolithic function, which allows
32  to perform all pattern-matches only once.
33 
34  Nearly all functions modifying Data.Map use balance.
35  The improvements are 12% for insert, 14% for delete (GHC 6.12.1).
36
37Tue Sep 14 16:20:10 CEST 2010  Milan Straka <fox@ucw.cz>
38  * Improve Data.Set benchmark.
39 
40  Add union, difference and intersection to Data.Set benchmark.
41
42Tue Sep 14 17:04:42 CEST 2010  Milan Straka <fox@ucw.cz>
43  * Correct Data.Set Arbitrary instance never to return unbalanced trees.
44 
45  The previous instance sometimes returned unbalanced trees,
46  which broke the tests.
47 
48  Also the new instance mimics Data.Map instance more closely in the shape
49  of the generated trees.
50
51New patches:
52
53[Added a test suite for Data.Set
54Johan Tibell <johan.tibell@gmail.com>**20100831124030
55 Ignore-this: f430dc302c0fcb8b5d62db2272a1d6f7
56 
57 Expression coverage: 74%
58] {
59hunk ./Data/Set.hs 39
60 
61 module Data.Set  (
62             -- * Set type
63+#if !defined(TESTING)   
64               Set          -- instance Eq,Ord,Show,Read,Data,Typeable
65hunk ./Data/Set.hs 41
66+#else
67+              Set(..)
68+#endif
69 
70             -- * Operators
71             , (\\)
72hunk ./Data/Set.hs 106
73             , showTree
74             , showTreeWith
75             , valid
76+
77+#if defined(TESTING)
78+            -- Internals (for testing)
79+            , bin
80+            , balanced
81+            , join
82+            , merge
83+#endif   
84             ) where
85 
86 import Prelude hiding (filter,foldr,null,map)
87hunk ./Data/Set.hs 552
88   showsPrec p xs = showParen (p > 10) $
89     showString "fromList " . shows (toList xs)
90 
91-{-
92-XXX unused code
93-
94-showSet :: (Show a) => [a] -> ShowS
95-showSet []     
96-  = showString "{}"
97-showSet (x:xs)
98-  = showChar '{' . shows x . showTail xs
99-  where
100-    showTail []       = showChar '}'
101-    showTail (x':xs') = showChar ',' . shows x' . showTail xs'
102--}
103-
104 {--------------------------------------------------------------------
105   Read
106 --------------------------------------------------------------------}
107hunk ./Data/Set.hs 608
108               _  -> trim cmplo cmphi l
109       _  -> trim cmplo cmphi r
110 
111-{-
112-XXX unused code
113-
114-trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)
115-trimMemberLo _  _     Tip = (False,Tip)
116-trimMemberLo lo cmphi t@(Bin _ x l r)
117-  = case compare lo x of
118-      LT -> case cmphi x of
119-              GT -> (member lo t, t)
120-              _  -> trimMemberLo lo cmphi l
121-      GT -> trimMemberLo lo cmphi r
122-      EQ -> (True,trim (compare lo) cmphi r)
123--}
124-
125 {--------------------------------------------------------------------
126   [filterGt x t] filter all values >[x] from tree [t]
127   [filterLt x t] filter all values <[x] from tree [t]
128hunk ./Data/Set.hs 1003
129           Bin sz _ l r -> case (realsize l,realsize r) of
130                             (Just n,Just m)  | n+m+1 == sz  -> Just sz
131                             _                -> Nothing
132-
133-{-
134-{--------------------------------------------------------------------
135-  Testing
136---------------------------------------------------------------------}
137-testTree :: [Int] -> Set Int
138-testTree xs   = fromList xs
139-test1 = testTree [1..20]
140-test2 = testTree [30,29..10]
141-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
142-
143-{--------------------------------------------------------------------
144-  QuickCheck
145---------------------------------------------------------------------}
146-qcheck prop
147-  = check config prop
148-  where
149-    config = Config
150-      { configMaxTest = 500
151-      , configMaxFail = 5000
152-      , configSize    = \n -> (div n 2 + 3)
153-      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
154-      }
155-
156-
157-{--------------------------------------------------------------------
158-  Arbitrary, reasonably balanced trees
159---------------------------------------------------------------------}
160-instance (Enum a) => Arbitrary (Set a) where
161-  arbitrary = sized (arbtree 0 maxkey)
162-            where maxkey  = 10000
163-
164-arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
165-arbtree lo hi n
166-  | n <= 0        = return Tip
167-  | lo >= hi      = return Tip
168-  | otherwise     = do{ i  <- choose (lo,hi)
169-                      ; m  <- choose (1,30)
170-                      ; let (ml,mr)  | m==(1::Int)= (1,2)
171-                                     | m==2       = (2,1)
172-                                     | m==3       = (1,1)
173-                                     | otherwise  = (2,2)
174-                      ; l  <- arbtree lo (i-1) (n `div` ml)
175-                      ; r  <- arbtree (i+1) hi (n `div` mr)
176-                      ; return (bin (toEnum i) l r)
177-                      } 
178-
179-
180-{--------------------------------------------------------------------
181-  Valid tree's
182---------------------------------------------------------------------}
183-forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
184-forValid f
185-  = forAll arbitrary $ \t ->
186---    classify (balanced t) "balanced" $
187-    classify (size t == 0) "empty" $
188-    classify (size t > 0  && size t <= 10) "small" $
189-    classify (size t > 10 && size t <= 64) "medium" $
190-    classify (size t > 64) "large" $
191-    balanced t ==> f t
192-
193-forValidIntTree :: Testable a => (Set Int -> a) -> Property
194-forValidIntTree f
195-  = forValid f
196-
197-forValidUnitTree :: Testable a => (Set Int -> a) -> Property
198-forValidUnitTree f
199-  = forValid f
200-
201-
202-prop_Valid
203-  = forValidUnitTree $ \t -> valid t
204-
205-{--------------------------------------------------------------------
206-  Single, Insert, Delete
207---------------------------------------------------------------------}
208-prop_Single :: Int -> Bool
209-prop_Single x
210-  = (insert x empty == singleton x)
211-
212-prop_InsertValid :: Int -> Property
213-prop_InsertValid k
214-  = forValidUnitTree $ \t -> valid (insert k t)
215-
216-prop_InsertDelete :: Int -> Set Int -> Property
217-prop_InsertDelete k t
218-  = not (member k t) ==> delete k (insert k t) == t
219-
220-prop_DeleteValid :: Int -> Property
221-prop_DeleteValid k
222-  = forValidUnitTree $ \t ->
223-    valid (delete k (insert k t))
224-
225-{--------------------------------------------------------------------
226-  Balance
227---------------------------------------------------------------------}
228-prop_Join :: Int -> Property
229-prop_Join x
230-  = forValidUnitTree $ \t ->
231-    let (l,r) = split x t
232-    in valid (join x l r)
233-
234-prop_Merge :: Int -> Property
235-prop_Merge x
236-  = forValidUnitTree $ \t ->
237-    let (l,r) = split x t
238-    in valid (merge l r)
239-
240-
241-{--------------------------------------------------------------------
242-  Union
243---------------------------------------------------------------------}
244-prop_UnionValid :: Property
245-prop_UnionValid
246-  = forValidUnitTree $ \t1 ->
247-    forValidUnitTree $ \t2 ->
248-    valid (union t1 t2)
249-
250-prop_UnionInsert :: Int -> Set Int -> Bool
251-prop_UnionInsert x t
252-  = union t (singleton x) == insert x t
253-
254-prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
255-prop_UnionAssoc t1 t2 t3
256-  = union t1 (union t2 t3) == union (union t1 t2) t3
257-
258-prop_UnionComm :: Set Int -> Set Int -> Bool
259-prop_UnionComm t1 t2
260-  = (union t1 t2 == union t2 t1)
261-
262-
263-prop_DiffValid
264-  = forValidUnitTree $ \t1 ->
265-    forValidUnitTree $ \t2 ->
266-    valid (difference t1 t2)
267-
268-prop_Diff :: [Int] -> [Int] -> Bool
269-prop_Diff xs ys
270-  =  toAscList (difference (fromList xs) (fromList ys))
271-    == List.sort ((List.\\) (nub xs)  (nub ys))
272-
273-prop_IntValid
274-  = forValidUnitTree $ \t1 ->
275-    forValidUnitTree $ \t2 ->
276-    valid (intersection t1 t2)
277-
278-prop_Int :: [Int] -> [Int] -> Bool
279-prop_Int xs ys
280-  =  toAscList (intersection (fromList xs) (fromList ys))
281-    == List.sort (nub ((List.intersect) (xs)  (ys)))
282-
283-{--------------------------------------------------------------------
284-  Lists
285---------------------------------------------------------------------}
286-prop_Ordered
287-  = forAll (choose (5,100)) $ \n ->
288-    let xs = [0..n::Int]
289-    in fromAscList xs == fromList xs
290-
291-prop_List :: [Int] -> Bool
292-prop_List xs
293-  = (sort (nub xs) == toList (fromList xs))
294--}
295addfile ./tests/Set.hs
296hunk ./tests/Set.hs 1
297+{-# LANGUAGE CPP, ScopedTypeVariables #-}
298+
299+-- QuickCheck properties for Data.Set
300+-- > ghc -DTESTING -fforce-recomp -O2 --make -fhpc -i..  Set.hs
301+
302+import Data.List (nub,sort)
303+import qualified Data.List as List
304+import Data.Set
305+import Prelude hiding (lookup, null, map ,filter)
306+import Test.QuickCheck
307+
308+main :: IO ()
309+main = do
310+    q $ label "prop_Valid" prop_Valid
311+    q $ label "prop_Single" prop_Single
312+    q $ label "prop_Single" prop_Single
313+    q $ label "prop_InsertValid" prop_InsertValid
314+    q $ label "prop_InsertValid" prop_InsertValid
315+    q $ label "prop_InsertDelete" prop_InsertDelete
316+    q $ label "prop_InsertDelete" prop_InsertDelete
317+    q $ label "prop_DeleteValid" prop_DeleteValid
318+    q $ label "prop_DeleteValid" prop_DeleteValid
319+    q $ label "prop_Join" prop_Join
320+    q $ label "prop_Join" prop_Join
321+    q $ label "prop_Merge" prop_Merge
322+    q $ label "prop_Merge" prop_Merge
323+    q $ label "prop_UnionValid" prop_UnionValid
324+    q $ label "prop_UnionValid" prop_UnionValid
325+    q $ label "prop_UnionInsert" prop_UnionInsert
326+    q $ label "prop_UnionInsert" prop_UnionInsert
327+    q $ label "prop_UnionAssoc" prop_UnionAssoc
328+    q $ label "prop_UnionAssoc" prop_UnionAssoc
329+    q $ label "prop_UnionComm" prop_UnionComm
330+    q $ label "prop_UnionComm" prop_UnionComm
331+    q $ label "prop_DiffValid" prop_DiffValid
332+    q $ label "prop_Diff" prop_Diff
333+    q $ label "prop_Diff" prop_Diff
334+    q $ label "prop_IntValid" prop_IntValid
335+    q $ label "prop_Int" prop_Int
336+    q $ label "prop_Int" prop_Int
337+    q $ label "prop_Ordered" prop_Ordered
338+    q $ label "prop_List" prop_List
339+    q $ label "prop_List" prop_List
340+  where
341+    q :: Testable prop => prop -> IO ()
342+    q = quickCheckWith args
343+
344+{--------------------------------------------------------------------
345+  QuickCheck
346+--------------------------------------------------------------------}
347+
348+args :: Args
349+args = stdArgs { maxSuccess = 500
350+               , maxDiscard = 500
351+               }
352+
353+{--------------------------------------------------------------------
354+  Arbitrary, reasonably balanced trees
355+--------------------------------------------------------------------}
356+instance (Enum a) => Arbitrary (Set a) where
357+    arbitrary = sized (arbtree 0 maxkey)
358+      where maxkey = 10000
359+
360+arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
361+arbtree lo hi n
362+    | n <= 0    = return Tip
363+    | lo >= hi  = return Tip
364+    | otherwise = do  i  <- choose (lo,hi)
365+                      m  <- choose (1,30)
366+                      let (ml,mr) | m==(1::Int) = (1,2)
367+                                  | m==2        = (2,1)
368+                                  | m==3        = (1,1)
369+                                  | otherwise   = (2,2)
370+                      l  <- arbtree lo (i-1) (n `div` ml)
371+                      r  <- arbtree (i+1) hi (n `div` mr)
372+                      return (bin (toEnum i) l r)
373+
374+{--------------------------------------------------------------------
375+  Valid tree's
376+--------------------------------------------------------------------}
377+forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
378+forValid f = forAll arbitrary $ \t ->
379+--    classify (balanced t) "balanced" $
380+    classify (size t == 0) "empty" $
381+    classify (size t > 0  && size t <= 10) "small" $
382+    classify (size t > 10 && size t <= 64) "medium" $
383+    classify (size t > 64) "large" $
384+    balanced t ==> f t
385+
386+forValidUnitTree :: Testable a => (Set Int -> a) -> Property
387+forValidUnitTree f = forValid f
388+
389+prop_Valid :: Property
390+prop_Valid = forValidUnitTree $ \t -> valid t
391+
392+{--------------------------------------------------------------------
393+  Single, Insert, Delete
394+--------------------------------------------------------------------}
395+prop_Single :: Int -> Bool
396+prop_Single x = (insert x empty == singleton x)
397+
398+prop_InsertValid :: Int -> Property
399+prop_InsertValid k = forValidUnitTree $ \t -> valid (insert k t)
400+
401+prop_InsertDelete :: Int -> Set Int -> Property
402+prop_InsertDelete k t = not (member k t) ==> delete k (insert k t) == t
403+
404+prop_DeleteValid :: Int -> Property
405+prop_DeleteValid k = forValidUnitTree $ \t -> valid (delete k (insert k t))
406+
407+{--------------------------------------------------------------------
408+  Balance
409+--------------------------------------------------------------------}
410+prop_Join :: Int -> Property
411+prop_Join x = forValidUnitTree $ \t ->
412+    let (l,r) = split x t
413+    in valid (join x l r)
414+
415+prop_Merge :: Int -> Property
416+prop_Merge x = forValidUnitTree $ \t ->
417+    let (l,r) = split x t
418+    in valid (merge l r)
419+
420+{--------------------------------------------------------------------
421+  Union
422+--------------------------------------------------------------------}
423+prop_UnionValid :: Property
424+prop_UnionValid
425+  = forValidUnitTree $ \t1 ->
426+    forValidUnitTree $ \t2 ->
427+    valid (union t1 t2)
428+
429+prop_UnionInsert :: Int -> Set Int -> Bool
430+prop_UnionInsert x t = union t (singleton x) == insert x t
431+
432+prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
433+prop_UnionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3
434+
435+prop_UnionComm :: Set Int -> Set Int -> Bool
436+prop_UnionComm t1 t2 = (union t1 t2 == union t2 t1)
437+
438+prop_DiffValid :: Property
439+prop_DiffValid = forValidUnitTree $ \t1 ->
440+    forValidUnitTree $ \t2 ->
441+    valid (difference t1 t2)
442+
443+prop_Diff :: [Int] -> [Int] -> Bool
444+prop_Diff xs ys = toAscList (difference (fromList xs) (fromList ys))
445+                  == List.sort ((List.\\) (nub xs)  (nub ys))
446+
447+prop_IntValid :: Property
448+prop_IntValid = forValidUnitTree $ \t1 ->
449+    forValidUnitTree $ \t2 ->
450+    valid (intersection t1 t2)
451+
452+prop_Int :: [Int] -> [Int] -> Bool
453+prop_Int xs ys = toAscList (intersection (fromList xs) (fromList ys))
454+                 == List.sort (nub ((List.intersect) (xs)  (ys)))
455+
456+{--------------------------------------------------------------------
457+  Lists
458+--------------------------------------------------------------------}
459+prop_Ordered :: Property
460+prop_Ordered = forAll (choose (5,100)) $ \n ->
461+    let xs = [0..n::Int]
462+    in fromAscList xs == fromList xs
463+
464+prop_List :: [Int] -> Bool
465+prop_List xs = (sort (nub xs) == toList (fromList xs))
466}
467[Added benchmarks for Data.Set
468Johan Tibell <johan.tibell@gmail.com>**20100831124225
469 Ignore-this: fcacf88761034b8c534d936f0b336cc0
470] {
471addfile ./benchmarks/Set.hs
472hunk ./benchmarks/Set.hs 1
473+{-# LANGUAGE BangPatterns #-}
474+
475+-- > ghc -DTESTING --make -O2 -fforce-recomp -i.. Set.hs
476+module Main where
477+
478+import Control.DeepSeq
479+import Control.Exception (evaluate)
480+import Control.Monad.Trans (liftIO)
481+import Criterion.Config
482+import Criterion.Main
483+import Data.List (foldl')
484+import qualified Data.Set as S
485+
486+instance NFData a => NFData (S.Set a) where
487+    rnf S.Tip = ()
488+    rnf (S.Bin _ a l r) = rnf a `seq` rnf l `seq` rnf r
489+
490+main = do
491+    let s = S.fromAscList elems :: S.Set Int
492+        s2 = S.fromAscList [-1, -2 .. -(2^10)] :: S.Set Int
493+    defaultMainWith
494+        defaultConfig
495+        (liftIO . evaluate $ rnf [s, s2])
496+        [ bench "member" $ nf (member elems) s
497+        , bench "insert" $ nf (ins elems) S.empty
498+        , bench "map" $ nf (S.map (+ 1)) s
499+        , bench "filter" $ nf (S.filter ((== 0) . (`mod` 2))) s
500+        , bench "partition" $ nf (S.partition ((== 0) . (`mod` 2))) s
501+        , bench "fold" $ nf (S.fold (:) []) s
502+        , bench "delete" $ nf (del elems) s
503+        , bench "findMin" $ nf S.findMin s
504+        , bench "findMax" $ nf S.findMax s
505+        , bench "deleteMin" $ nf S.deleteMin s
506+        , bench "deleteMax" $ nf S.deleteMax s
507+        , bench "unions" $ nf S.unions [s, s2]
508+        , bench "union" $ nf (S.union s) s2
509+        ]
510+  where
511+    elems = [1..2^10]
512+
513+member :: [Int] -> S.Set Int -> Int
514+member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs
515+
516+ins :: [Int] -> S.Set Int -> S.Set Int
517+ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs
518+
519+del :: [Int] -> S.Set Int -> S.Set Int
520+del xs s0 = foldl' (\s k -> S.delete k s) s0 xs
521}
522[Improved performance of Data.Set
523Johan Tibell <johan.tibell@gmail.com>**20100831124352
524 Ignore-this: 38a304a0408d29a2956aa9a1fc0ce755
525 
526 Performance improvements are due to manually applying the
527 worker/wrapper transformation and strictifying the keys.
528 
529 Average speed-up is 32% on a 2GHz Core 2 Duo on OS X 10.5.8
530] {
531hunk ./Data/Set.hs 23
532 -- trees of /bounded balance/) as described by:
533 --
534 --    * Stephen Adams, \"/Efficient sets: a balancing act/\",
535---     Journal of Functional Programming 3(4):553-562, October 1993,
536---     <http://www.swiss.ai.mit.edu/~adams/BB/>.
537+--      Journal of Functional Programming 3(4):553-562, October 1993,
538+--      <http://www.swiss.ai.mit.edu/~adams/BB/>.
539 --
540 --    * J. Nievergelt and E.M. Reingold,
541hunk ./Data/Set.hs 27
542---     \"/Binary search trees of bounded balance/\",
543---     SIAM journal of computing 2(1), March 1973.
544+--      \"/Binary search trees of bounded balance/\",
545+--      SIAM journal of computing 2(1), March 1973.
546 --
547 -- Note that the implementation is /left-biased/ -- the elements of a
548 -- first argument are always preferred to the second, for example in
549hunk ./Data/Set.hs 63
550             , delete
551             
552             -- * Combine
553-            , union, unions
554+            , union
555+            , unions
556             , difference
557             , intersection
558             
559hunk ./Data/Set.hs 75
560             , splitMember
561 
562             -- * Map
563-           , map
564-           , mapMonotonic
565+            , map
566+            , mapMonotonic
567 
568             -- * Fold
569             , fold
570hunk ./Data/Set.hs 146
571 -- | /O(n+m)/. See 'difference'.
572 (\\) :: Ord a => Set a -> Set a -> Set a
573 m1 \\ m2 = difference m1 m2
574+{-# INLINE (\\) #-}
575 
576 {--------------------------------------------------------------------
577   Sets are size balanced trees
578hunk ./Data/Set.hs 189
579 --------------------------------------------------------------------}
580 -- | /O(1)/. Is this the empty set?
581 null :: Set a -> Bool
582-null t
583-  = case t of
584-      Tip    -> True
585-      Bin {} -> False
586+null Tip      = True
587+null (Bin {}) = False
588+{-# INLINE null #-}
589 
590 -- | /O(1)/. The number of elements in the set.
591 size :: Set a -> Int
592hunk ./Data/Set.hs 195
593-size t
594-  = case t of
595-      Tip          -> 0
596-      Bin sz _ _ _ -> sz
597+size = go
598+  where
599+    go Tip            = 0
600+    go (Bin sz _ _ _) = sz
601+{-# INLINE size #-}
602 
603 -- | /O(log n)/. Is the element in the set?
604 member :: Ord a => a -> Set a -> Bool
605hunk ./Data/Set.hs 203
606-member x t
607-  = case t of
608-      Tip -> False
609-      Bin _ y l r
610-          -> case compare x y of
611-               LT -> member x l
612-               GT -> member x r
613-               EQ -> True       
614-
615+member x = x `seq` go
616+  where
617+    go Tip = False
618+    go (Bin _ y l r) = case compare x y of
619+        LT -> go l
620+        GT -> go r
621+        EQ -> True       
622+{-# INLINE member #-}
623+       
624 -- | /O(log n)/. Is the element not in the set?
625 notMember :: Ord a => a -> Set a -> Bool
626hunk ./Data/Set.hs 214
627-notMember x t = not $ member x t
628+notMember a t = not $ member a t
629+{-# INLINE notMember #-}
630 
631 {--------------------------------------------------------------------
632   Construction
633hunk ./Data/Set.hs 222
634 --------------------------------------------------------------------}
635 -- | /O(1)/. The empty set.
636 empty  :: Set a
637-empty
638-  = Tip
639+empty = Tip
640+{-# INLINE empty #-}
641 
642 -- | /O(1)/. Create a singleton set.
643 singleton :: a -> Set a
644hunk ./Data/Set.hs 227
645-singleton x
646-  = Bin 1 x Tip Tip
647+singleton x = Bin 1 x Tip Tip
648+{-# INLINE singleton #-}
649 
650 {--------------------------------------------------------------------
651   Insertion, Deletion
652hunk ./Data/Set.hs 237
653 -- If the set already contains an element equal to the given value,
654 -- it is replaced with the new value.
655 insert :: Ord a => a -> Set a -> Set a
656-insert x t
657-  = case t of
658-      Tip -> singleton x
659-      Bin sz y l r
660-          -> case compare x y of
661-               LT -> balance y (insert x l) r
662-               GT -> balance y l (insert x r)
663-               EQ -> Bin sz x l r
664-
665+insert x = x `seq` go
666+  where
667+    go Tip = singleton x
668+    go (Bin sz y l r) = case compare x y of
669+        LT -> balance y (go l) r
670+        GT -> balance y l (go r)
671+        EQ -> Bin sz x l r
672+{-# INLINE insert #-}
673 
674 -- | /O(log n)/. Delete an element from a set.
675 delete :: Ord a => a -> Set a -> Set a
676hunk ./Data/Set.hs 248
677-delete x t
678-  = case t of
679-      Tip -> Tip
680-      Bin _ y l r
681-          -> case compare x y of
682-               LT -> balance y (delete x l) r
683-               GT -> balance y l (delete x r)
684-               EQ -> glue l r
685+delete x = x `seq` go
686+  where
687+    go Tip = Tip
688+    go (Bin _ y l r) = case compare x y of
689+        LT -> balance y (go l) r
690+        GT -> balance y l (go r)
691+        EQ -> glue l r
692+{-# INLINE delete #-}
693 
694 {--------------------------------------------------------------------
695   Subset
696hunk ./Data/Set.hs 308
697 deleteMax (Bin _ x l r)   = balance x l (deleteMax r)
698 deleteMax Tip             = Tip
699 
700-
701 {--------------------------------------------------------------------
702   Union.
703 --------------------------------------------------------------------}
704hunk ./Data/Set.hs 313
705 -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
706 unions :: Ord a => [Set a] -> Set a
707-unions ts
708-  = foldlStrict union empty ts
709-
710+unions = foldlStrict union empty
711+{-# INLINE unions #-}
712 
713 -- | /O(n+m)/. The union of two sets, preferring the first set when
714 -- equal elements are encountered.
715hunk ./Data/Set.hs 324
716 union Tip t2  = t2
717 union t1 Tip  = t1
718 union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2
719+{-# INLINE union #-}
720 
721 hedgeUnion :: Ord a
722            => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a
723hunk ./Data/Set.hs 347
724 difference Tip _   = Tip
725 difference t1 Tip  = t1
726 difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2
727+{-# INLINE difference #-}
728 
729 hedgeDiff :: Ord a
730           => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a
731hunk ./Data/Set.hs 397
732 --------------------------------------------------------------------}
733 -- | /O(n)/. Filter all elements that satisfy the predicate.
734 filter :: Ord a => (a -> Bool) -> Set a -> Set a
735-filter _ Tip = Tip
736-filter p (Bin _ x l r)
737-  | p x       = join x (filter p l) (filter p r)
738-  | otherwise = merge (filter p l) (filter p r)
739+filter p = go
740+  where
741+    go Tip = Tip
742+    go (Bin _ x l r)
743+        | p x       = join x (go l) (go r)
744+        | otherwise = merge (go l) (go r)
745+{-# INLINE filter #-}
746 
747 -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
748 -- the predicate and one with all elements that don't satisfy the predicate.
749hunk ./Data/Set.hs 409
750 -- See also 'split'.
751 partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)
752-partition _ Tip = (Tip,Tip)
753-partition p (Bin _ x l r)
754-  | p x       = (join x l1 r1,merge l2 r2)
755-  | otherwise = (merge l1 r1,join x l2 r2)
756+partition p = go
757   where
758hunk ./Data/Set.hs 411
759-    (l1,l2) = partition p l
760-    (r1,r2) = partition p r
761+    go Tip = (Tip, Tip)
762+    go (Bin _ x l r) = case (go l, go r) of
763+        ((l1, l2), (r1, r2))
764+            | p x       -> (join x l1 r1, merge l2 r2)
765+            | otherwise -> (merge l1 r1, join x l2 r2)
766+{-# INLINE partition #-}
767 
768 {----------------------------------------------------------------------
769   Map
770hunk ./Data/Set.hs 430
771 
772 map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b
773 map f = fromList . List.map f . toList
774+{-# INLINE map #-}
775 
776 -- | /O(n)/. The
777 --
778hunk ./Data/Set.hs 443
779 -- >     where ls = toList s
780 
781 mapMonotonic :: (a->b) -> Set a -> Set b
782-mapMonotonic _ Tip = Tip
783-mapMonotonic f (Bin sz x l r) =
784-    Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
785-
786+mapMonotonic f = go
787+  where
788+    go Tip = Tip
789+    go (Bin sz x l r) = Bin sz (f x) (go l) (go r)
790+{-# INLINE mapMonotonic #-}
791 
792 {--------------------------------------------------------------------
793   Fold
794hunk ./Data/Set.hs 454
795 --------------------------------------------------------------------}
796 -- | /O(n)/. Fold over the elements of a set in an unspecified order.
797 fold :: (a -> b -> b) -> b -> Set a -> b
798-fold f z s
799-  = foldr f z s
800+fold = foldr
801+{-# INLINE fold #-}
802 
803 -- | /O(n)/. Post-order fold.
804 foldr :: (a -> b -> b) -> b -> Set a -> b
805hunk ./Data/Set.hs 459
806-foldr _ z Tip           = z
807-foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
808+foldr f = go
809+  where
810+    go z Tip           = z
811+    go z (Bin _ x l r) = go (f x (go z r)) l
812+{-# INLINE foldr #-}
813 
814 {--------------------------------------------------------------------
815   List variations
816hunk ./Data/Set.hs 470
817 --------------------------------------------------------------------}
818 -- | /O(n)/. The elements of a set.
819 elems :: Set a -> [a]
820-elems s
821-  = toList s
822+elems = toList
823+{-# INLINE elems #-}
824 
825 {--------------------------------------------------------------------
826   Lists
827hunk ./Data/Set.hs 478
828 --------------------------------------------------------------------}
829 -- | /O(n)/. Convert the set to a list of elements.
830 toList :: Set a -> [a]
831-toList s
832-  = toAscList s
833+toList = toAscList
834+{-# INLINE toList #-}
835 
836 -- | /O(n)/. Convert the set to an ascending list of elements.
837 toAscList :: Set a -> [a]
838hunk ./Data/Set.hs 483
839-toAscList t   
840-  = foldr (:) [] t
841-
842+toAscList = foldr (:) []
843+{-# INLINE toAscList #-}
844 
845 -- | /O(n*log n)/. Create a set from a list of elements.
846 fromList :: Ord a => [a] -> Set a
847hunk ./Data/Set.hs 488
848-fromList xs
849-  = foldlStrict ins empty xs
850+fromList = foldlStrict ins empty
851   where
852     ins t x = insert x t
853hunk ./Data/Set.hs 491
854+{-# INLINE fromList #-}
855 
856 {--------------------------------------------------------------------
857   Building trees from ascending/descending lists can be done in linear time.
858hunk ./Data/Set.hs 629
859       LT -> join x (filterGt cmp l) r
860       GT -> filterGt cmp r
861       EQ -> r
862+{-# INLINE filterGt #-}
863       
864 filterLt :: (a -> Ordering) -> Set a -> Set a
865 filterLt _ Tip = Tip
866hunk ./Data/Set.hs 638
867       LT -> filterLt cmp l
868       GT -> join x l (filterLt cmp r)
869       EQ -> l
870-
871+{-# INLINE filterLt #-}
872 
873 {--------------------------------------------------------------------
874   Split
875hunk ./Data/Set.hs 880
876   Utilities
877 --------------------------------------------------------------------}
878 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
879-foldlStrict f z xs
880-  = case xs of
881-      []     -> z
882-      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
883-
884+foldlStrict f = go
885+  where
886+    go z []     = z
887+    go z (x:xs) = z `seq` go (f z x) xs
888+{-# INLINE foldlStrict #-}
889 
890 {--------------------------------------------------------------------
891   Debugging
892}
893[Make the Set store the elements evaluated (bang added).
894Milan Straka <fox@ucw.cz>**20100913165132
895 Ignore-this: b3f230db5bf30d93d3fddf2c81c5f3b4
896] hunk ./Data/Set.hs 153
897 --------------------------------------------------------------------}
898 -- | A set of values @a@.
899 data Set a    = Tip
900-              | Bin {-# UNPACK #-} !Size a !(Set a) !(Set a)
901+              | Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)
902 
903 type Size     = Int
904 
905[Improve performance of Data.Set union and difference operations.
906Milan Straka <fox@ucw.cz>**20100914135725
907 Ignore-this: 6dc4a186ea060b9cdb9e783db71ca280
908 
909 Use datatype storing evaluated bound instead of high-order functions.
910 The improvements are over 25% for both union and difference (GHC 6.12.1).
911] {
912hunk ./Data/Set.hs 246
913         EQ -> Bin sz x l r
914 {-# INLINE insert #-}
915 
916+-- Insert an element to the set only if it is not in the set. Used by
917+-- `union`.
918+insertR :: Ord a => a -> Set a -> Set a
919+insertR x = x `seq` go
920+  where
921+    go Tip = singleton x
922+    go t@(Bin sz y l r) = case compare x y of
923+        LT -> balance y (go l) r
924+        GT -> balance y l (go r)
925+        EQ -> t
926+{-# INLINE insertR #-}
927+
928 -- | /O(log n)/. Delete an element from a set.
929 delete :: Ord a => a -> Set a -> Set a
930 delete x = x `seq` go
931hunk ./Data/Set.hs 335
932 union :: Ord a => Set a -> Set a -> Set a
933 union Tip t2  = t2
934 union t1 Tip  = t1
935-union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2
936+union (Bin _ x Tip Tip) t = insert x t
937+union t (Bin _ x Tip Tip) = insertR x t
938+union t1 t2 = hedgeUnion NothingS NothingS t1 t2
939 {-# INLINE union #-}
940 
941 hedgeUnion :: Ord a
942hunk ./Data/Set.hs 341
943-           => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a
944+           => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a
945 hedgeUnion _     _     t1 Tip
946   = t1
947hunk ./Data/Set.hs 344
948-hedgeUnion cmplo cmphi Tip (Bin _ x l r)
949-  = join x (filterGt cmplo l) (filterLt cmphi r)
950-hedgeUnion cmplo cmphi (Bin _ x l r) t2
951-  = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2))
952-           (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))
953+hedgeUnion blo bhi Tip (Bin _ x l r)
954+  = join x (filterGt blo l) (filterLt bhi r)
955+hedgeUnion blo bhi (Bin _ x l r) t2
956+  = join x (hedgeUnion blo bmi l (trim blo bmi t2))
957+           (hedgeUnion bmi bhi r (trim bmi bhi t2))
958   where
959hunk ./Data/Set.hs 350
960-    cmpx y  = compare x y
961+    bmi = JustS x
962 
963 {--------------------------------------------------------------------
964   Difference
965hunk ./Data/Set.hs 360
966 difference :: Ord a => Set a -> Set a -> Set a
967 difference Tip _   = Tip
968 difference t1 Tip  = t1
969-difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2
970+difference t1 t2   = hedgeDiff NothingS NothingS t1 t2
971 {-# INLINE difference #-}
972 
973 hedgeDiff :: Ord a
974hunk ./Data/Set.hs 364
975-          => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a
976+          => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a
977 hedgeDiff _ _ Tip _
978   = Tip
979hunk ./Data/Set.hs 367
980-hedgeDiff cmplo cmphi (Bin _ x l r) Tip
981-  = join x (filterGt cmplo l) (filterLt cmphi r)
982-hedgeDiff cmplo cmphi t (Bin _ x l r)
983-  = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l)
984-          (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)
985+hedgeDiff blo bhi (Bin _ x l r) Tip
986+  = join x (filterGt blo l) (filterLt bhi r)
987+hedgeDiff blo bhi t (Bin _ x l r)
988+  = merge (hedgeDiff blo bmi (trim blo bmi t) l)
989+          (hedgeDiff bmi bhi (trim bmi bhi t) r)
990   where
991hunk ./Data/Set.hs 373
992-    cmpx y = compare x y
993+    bmi = JustS x
994 
995 {--------------------------------------------------------------------
996   Intersection
997hunk ./Data/Set.hs 603
998 
999 {--------------------------------------------------------------------
1000   Utility functions that return sub-ranges of the original
1001-  tree. Some functions take a comparison function as argument to
1002-  allow comparisons against infinite values. A function [cmplo x]
1003-  should be read as [compare lo x].
1004+  tree. Some functions take a `Maybe value` as an argument to
1005+  allow comparisons against infinite values. These are called `blow`
1006+  (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).
1007+  We use MaybeS value, which is a Maybe strict in the Just case.
1008 
1009hunk ./Data/Set.hs 608
1010-  [trim cmplo cmphi t]  A tree that is either empty or where [cmplo x == LT]
1011-                        and [cmphi x == GT] for the value [x] of the root.
1012-  [filterGt cmp t]      A tree where for all values [k]. [cmp k == LT]
1013-  [filterLt cmp t]      A tree where for all values [k]. [cmp k == GT]
1014+  [trim blow bhigh t]   A tree that is either empty or where [x > blow]
1015+                        and [x < bhigh] for the value [x] of the root.
1016+  [filterGt blow t]     A tree where for all values [k]. [k > blow]
1017+  [filterLt bhigh t]    A tree where for all values [k]. [k < bhigh]
1018 
1019   [split k t]           Returns two trees [l] and [r] where all values
1020                         in [l] are <[k] and all keys in [r] are >[k].
1021hunk ./Data/Set.hs 619
1022                         was found in the tree.
1023 --------------------------------------------------------------------}
1024 
1025+data MaybeS a = NothingS | JustS !a
1026+
1027 {--------------------------------------------------------------------
1028hunk ./Data/Set.hs 622
1029-  [trim lo hi t] trims away all subtrees that surely contain no
1030-  values between the range [lo] to [hi]. The returned tree is either
1031-  empty or the key of the root is between @lo@ and @hi@.
1032+  [trim blo bhi t] trims away all subtrees that surely contain no
1033+  values between the range [blo] to [bhi]. The returned tree is either
1034+  empty or the key of the root is between @blo@ and @bhi@.
1035 --------------------------------------------------------------------}
1036hunk ./Data/Set.hs 626
1037-trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a
1038-trim _     _     Tip = Tip
1039-trim cmplo cmphi t@(Bin _ x l r)
1040-  = case cmplo x of
1041-      LT -> case cmphi x of
1042-              GT -> t
1043-              _  -> trim cmplo cmphi l
1044-      _  -> trim cmplo cmphi r
1045+trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a
1046+trim NothingS   NothingS   t = t
1047+trim (JustS lx) NothingS   t = greater t where greater (Bin _ x _ r) | x <= lx = greater r
1048+                                               greater t = t
1049+trim NothingS   (JustS hx) t = lesser t  where lesser  (Bin _ x l _) | x >= hx = lesser  l
1050+                                               lesser  t = t
1051+trim (JustS lx) (JustS hx) t = middle t  where middle  (Bin _ x _ r) | x <= lx = middle  r
1052+                                               middle  (Bin _ x l _) | x >= hx = middle  l
1053+                                               middle  t = t
1054 
1055 {--------------------------------------------------------------------
1056hunk ./Data/Set.hs 637
1057-  [filterGt x t] filter all values >[x] from tree [t]
1058-  [filterLt x t] filter all values <[x] from tree [t]
1059+  [filterGt b t] filter all values >[b] from tree [t]
1060+  [filterLt b t] filter all values <[b] from tree [t]
1061 --------------------------------------------------------------------}
1062hunk ./Data/Set.hs 640
1063-filterGt :: (a -> Ordering) -> Set a -> Set a
1064-filterGt _ Tip = Tip
1065-filterGt cmp (Bin _ x l r)
1066-  = case cmp x of
1067-      LT -> join x (filterGt cmp l) r
1068-      GT -> filterGt cmp r
1069-      EQ -> r
1070+filterGt :: Ord a => MaybeS a -> Set a -> Set a
1071+filterGt NothingS t = t
1072+filterGt (JustS b) t = filter' t
1073+  where filter' Tip = Tip
1074+        filter' (Bin _ x l r) = case compare b x of LT -> join x (filter' l) r
1075+                                                    EQ -> r
1076+                                                    GT -> filter' r
1077 {-# INLINE filterGt #-}
1078       
1079hunk ./Data/Set.hs 649
1080-filterLt :: (a -> Ordering) -> Set a -> Set a
1081-filterLt _ Tip = Tip
1082-filterLt cmp (Bin _ x l r)
1083-  = case cmp x of
1084-      LT -> filterLt cmp l
1085-      GT -> join x l (filterLt cmp r)
1086-      EQ -> l
1087+filterLt :: Ord a => MaybeS a -> Set a -> Set a
1088+filterLt NothingS t = t
1089+filterLt (JustS b) t = filter' t
1090+  where filter' Tip = Tip
1091+        filter' (Bin _ x l r) = case compare x b of LT -> join x l (filter' r)
1092+                                                    EQ -> l
1093+                                                    GT -> filter' l
1094 {-# INLINE filterLt #-}
1095 
1096 {--------------------------------------------------------------------
1097}
1098[Improve the performance of Data.Set balance function.
1099Milan Straka <fox@ucw.cz>**20100914140417
1100 Ignore-this: 577c511c219695b8d483af546c7387e8
1101 
1102 The balance function is now one monolithic function, which allows
1103 to perform all pattern-matches only once.
1104 
1105 Nearly all functions modifying Data.Map use balance.
1106 The improvements are 12% for insert, 14% for delete (GHC 6.12.1).
1107] {
1108hunk ./Data/Set.hs 805
1109   size of one of them. (a rotation).
1110 
1111   [delta] is the maximal relative difference between the sizes of
1112-          two trees, it corresponds with the [w] in Adams' paper,
1113-          or equivalently, [1/delta] corresponds with the $\alpha$
1114-          in Nievergelt's paper. Adams shows that [delta] should
1115-          be larger than 3.745 in order to garantee that the
1116-          rotations can always restore balance.         
1117-
1118+          two trees, it corresponds with the [w] in Adams' paper.
1119   [ratio] is the ratio between an outer and inner sibling of the
1120           heavier subtree in an unbalanced setting. It determines
1121           whether a double or single rotation should be performed
1122hunk ./Data/Set.hs 812
1123           to restore balance. It is correspondes with the inverse
1124           of $\alpha$ in Adam's article.
1125 
1126-  Note that:
1127+  Note that according to the Adam's paper:
1128   - [delta] should be larger than 4.646 with a [ratio] of 2.
1129   - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1130hunk ./Data/Set.hs 815
1131
1132+
1133+  But the Adam's paper is errorneous:
1134+  - it can be proved that for delta=2 and delta>=5 there does
1135+    not exist any ratio that would work
1136+  - delta=4.5 and ratio=2 does not work
1137+
1138+  That leaves two reasonable variants, delta=3 and delta=4,
1139+  both with ratio=2.
1140+
1141   - A lower [delta] leads to a more 'perfectly' balanced tree.
1142   - A higher [delta] performs less rebalancing.
1143 
1144hunk ./Data/Set.hs 827
1145-  - Balancing is automatic for random data and a balancing
1146-    scheme is only necessary to avoid pathological worst cases.
1147-    Almost any choice will do in practice
1148-   
1149-  - Allthough it seems that a rather large [delta] may perform better
1150-    than smaller one, measurements have shown that the smallest [delta]
1151-    of 4 is actually the fastest on a wide range of operations. It
1152-    especially improves performance on worst-case scenarios like
1153-    a sequence of ordered insertions.
1154+  In the benchmarks, delta=3 is faster on insert operations,
1155+  but delta=4 has better overall performance, so we use delta=4.
1156+
1157+  Note: in contrast to Adam's paper, we perform the rebalance
1158+  even in the case when (size left == delta * size right), instead
1159+  when (size left > delta * size) as in the paper. Both are correct,
1160+  but the former is slightly faster overall.
1161 
1162hunk ./Data/Set.hs 835
1163-  Note: in contrast to Adams' paper, we use a ratio of (at least) 2
1164-  to decide whether a single or double rotation is needed. Allthough
1165-  he actually proves that this ratio is needed to maintain the
1166-  invariants, his implementation uses a (invalid) ratio of 1.
1167-  He is aware of the problem though since he has put a comment in his
1168-  original source code that he doesn't care about generating a
1169-  slightly inbalanced tree since it doesn't seem to matter in practice.
1170-  However (since we use quickcheck :-) we will stick to strictly balanced
1171-  trees.
1172 --------------------------------------------------------------------}
1173 delta,ratio :: Int
1174 delta = 4
1175hunk ./Data/Set.hs 840
1176 ratio = 2
1177 
1178-balance :: a -> Set a -> Set a -> Set a
1179-balance x l r
1180-  | sizeL + sizeR <= 1    = Bin sizeX x l r
1181-  | sizeR >= delta*sizeL  = rotateL x l r
1182-  | sizeL >= delta*sizeR  = rotateR x l r
1183-  | otherwise             = Bin sizeX x l r
1184-  where
1185-    sizeL = size l
1186-    sizeR = size r
1187-    sizeX = sizeL + sizeR + 1
1188-
1189--- rotate
1190-rotateL :: a -> Set a -> Set a -> Set a
1191-rotateL x l r@(Bin _ _ ly ry)
1192-  | size ly < ratio*size ry = singleL x l r
1193-  | otherwise               = doubleL x l r
1194-rotateL _ _ Tip = error "rotateL Tip"
1195+-- The balance function is equivalent to the following:
1196+--
1197+--   balance :: a -> Set a -> Set a -> Set a
1198+--   balance x l r
1199+--     | sizeL + sizeR <= 1    = Bin sizeX x l r
1200+--     | sizeR >= delta*sizeL  = rotateL x l r
1201+--     | sizeL >= delta*sizeR  = rotateR x l r
1202+--     | otherwise             = Bin sizeX x l r
1203+--     where
1204+--       sizeL = size l
1205+--       sizeR = size r
1206+--       sizeX = sizeL + sizeR + 1
1207+--
1208+--   rotateL :: a -> Set a -> Set a -> Set a
1209+--   rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r
1210+--                                 | otherwise               = doubleL x l r
1211+--   rotateR :: a -> Set a -> Set a -> Set a
1212+--   rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r
1213+--                                 | otherwise               = doubleR x l r
1214+--
1215+--   singleL, singleR :: a -> Set a -> Set a -> Set a
1216+--   singleL x1 t1 (Bin _ x2 t2 t3)  = bin x2 (bin x1 t1 t2) t3
1217+--   singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)
1218+--
1219+--   doubleL, doubleR :: a -> Set a -> Set a -> Set a
1220+--   doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
1221+--   doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
1222+--
1223+-- It is only written in such a way that every node is pattern-matched only once.
1224 
1225hunk ./Data/Set.hs 870
1226-rotateR :: a -> Set a -> Set a -> Set a
1227-rotateR x l@(Bin _ _ ly ry) r
1228-  | size ry < ratio*size ly = singleR x l r
1229-  | otherwise               = doubleR x l r
1230-rotateR _ Tip _ = error "rotateL Tip"
1231-
1232--- basic rotations
1233-singleL, singleR :: a -> Set a -> Set a -> Set a
1234-singleL x1 t1 (Bin _ x2 t2 t3)  = bin x2 (bin x1 t1 t2) t3
1235-singleL _  _  Tip               = error "singleL"
1236-singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)
1237-singleR _  Tip              _   = error "singleR"
1238+balance :: a -> Set a -> Set a -> Set a
1239+balance x l r = case l of
1240+  Tip -> case r of
1241+           Tip -> Bin 1 x Tip Tip
1242+           r@(Bin rs rx Tip Tip) -> Bin 2 x Tip r
1243+           r@(Bin rs rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr
1244+           r@(Bin rs rx rl@(Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
1245+           r@(Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs rrx rrl rrr))
1246+             | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
1247+             | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
1248 
1249hunk ./Data/Set.hs 881
1250-doubleL, doubleR :: a -> Set a -> Set a -> Set a
1251-doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
1252-doubleL _ _ _ = error "doubleL"
1253-doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
1254-doubleR _ _ _ = error "doubleR"
1255+  l@(Bin ls lx ll lr) -> case r of
1256+           Tip -> case (ll, lr) of
1257+                    (Tip, Tip) -> Bin 2 x l Tip
1258+                    (Tip, lr@(Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
1259+                    (ll@(Bin _ _ _ _), Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)
1260+                    (ll@(Bin lls llx lll llr), lr@(Bin lrs lrx lrl lrr))
1261+                      | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
1262+                      | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
1263+           r@(Bin rs rx rl rr)
1264+              | rs >= delta*ls  -> case (rl, rr) of
1265+                   (Bin rls rlx rll rlr, Bin rrs rrx rrl rrr)
1266+                     | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
1267+                     | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
1268+              | ls >= delta*rs  -> case (ll, lr) of
1269+                   (Bin lls llx lll llr, Bin lrs lrx lrl lrr)
1270+                     | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
1271+                     | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
1272+              | otherwise -> Bin (1+ls+rs) x l r
1273 
1274 
1275 {--------------------------------------------------------------------
1276}
1277[Improve Data.Set benchmark.
1278Milan Straka <fox@ucw.cz>**20100914142010
1279 Ignore-this: 9b878ae3aa5a43ef083abfd7f9b22513
1280 
1281 Add union, difference and intersection to Data.Set benchmark.
1282] {
1283hunk ./benchmarks/Set.hs 20
1284 
1285 main = do
1286     let s = S.fromAscList elems :: S.Set Int
1287-        s2 = S.fromAscList [-1, -2 .. -(2^10)] :: S.Set Int
1288+        s_even = S.fromAscList elems_even :: S.Set Int
1289+        s_odd = S.fromAscList elems_odd :: S.Set Int
1290     defaultMainWith
1291         defaultConfig
1292hunk ./benchmarks/Set.hs 24
1293-        (liftIO . evaluate $ rnf [s, s2])
1294+        (liftIO . evaluate $ rnf [s, s_even, s_odd])
1295         [ bench "member" $ nf (member elems) s
1296         , bench "insert" $ nf (ins elems) S.empty
1297         , bench "map" $ nf (S.map (+ 1)) s
1298hunk ./benchmarks/Set.hs 36
1299         , bench "findMax" $ nf S.findMax s
1300         , bench "deleteMin" $ nf S.deleteMin s
1301         , bench "deleteMax" $ nf S.deleteMax s
1302-        , bench "unions" $ nf S.unions [s, s2]
1303-        , bench "union" $ nf (S.union s) s2
1304+        , bench "unions" $ nf S.unions [s_even, s_odd]
1305+        , bench "union" $ nf (S.union s_even) s_odd
1306+        , bench "difference" $ nf (S.difference s) s_even
1307+        , bench "intersection" $ nf (S.intersection s) s_even
1308         ]
1309   where
1310     elems = [1..2^10]
1311hunk ./benchmarks/Set.hs 43
1312+    elems_even = [2,4..2^10]
1313+    elems_odd = [1,3..2^10]
1314 
1315 member :: [Int] -> S.Set Int -> Int
1316 member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs
1317}
1318[Correct Data.Set Arbitrary instance never to return unbalanced trees.
1319Milan Straka <fox@ucw.cz>**20100914150442
1320 Ignore-this: b5c70fa98a56f225b8eb5faf420677b0
1321 
1322 The previous instance sometimes returned unbalanced trees,
1323 which broke the tests.
1324 
1325 Also the new instance mimics Data.Map instance more closely in the shape
1326 of the generated trees.
1327] {
1328move ./tests/Set.hs ./tests/set-properties.hs
1329hunk ./tests/set-properties.hs 4
1330 {-# LANGUAGE CPP, ScopedTypeVariables #-}
1331 
1332 -- QuickCheck properties for Data.Set
1333--- > ghc -DTESTING -fforce-recomp -O2 --make -fhpc -i..  Set.hs
1334+-- > ghc -DTESTING -fforce-recomp -O2 --make -fhpc -i..  set-properties.hs
1335 
1336 import Data.List (nub,sort)
1337 import qualified Data.List as List
1338hunk ./tests/set-properties.hs 65
1339       where maxkey = 10000
1340 
1341 arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
1342-arbtree lo hi n
1343-    | n <= 0    = return Tip
1344-    | lo >= hi  = return Tip
1345-    | otherwise = do  i  <- choose (lo,hi)
1346-                      m  <- choose (1,30)
1347-                      let (ml,mr) | m==(1::Int) = (1,2)
1348-                                  | m==2        = (2,1)
1349-                                  | m==3        = (1,1)
1350-                                  | otherwise   = (2,2)
1351-                      l  <- arbtree lo (i-1) (n `div` ml)
1352-                      r  <- arbtree (i+1) hi (n `div` mr)
1353-                      return (bin (toEnum i) l r)
1354+arbtree lo hi n = do t <- gentree lo hi n
1355+                     if balanced t then return t else arbtree lo hi n
1356+  where gentree lo hi n
1357+          | n <= 0    = return Tip
1358+          | lo >= hi  = return Tip
1359+          | otherwise = do  i  <- choose (lo,hi)
1360+                            m  <- choose (1,70)
1361+                            let (ml,mr) | m==(1::Int) = (1,2)
1362+                                        | m==2        = (2,1)
1363+                                        | m==3        = (1,1)
1364+                                        | otherwise   = (2,2)
1365+                            l  <- gentree lo (i-1) (n `div` ml)
1366+                            r  <- gentree (i+1) hi (n `div` mr)
1367+                            return (bin (toEnum i) l r)
1368 
1369 {--------------------------------------------------------------------
1370   Valid tree's
1371}
1372
1373Context:
1374
1375[fix warnings
1376Simon Marlow <marlowsd@gmail.com>**20100831114555
1377 Ignore-this: 53df71bc054a779b8ad2dad89c09e02d
1378]
1379[Missing MagicHash for IntSet
1380Don Stewart <dons@galois.com>**20100831093446
1381 Ignore-this: d075f760adb9a2aa0ee04676e38a07cc
1382]
1383[Performance improvements for Data.IntMap (worker/wrapper and inlining)
1384Don Stewart <dons@galois.com>**20100831093316
1385 Ignore-this: 206036448558d270f0eb85ef4cd55368
1386]
1387[Add criterion-based benchmarking for IntMap
1388Don Stewart <dons@galois.com>**20100831093240
1389 Ignore-this: d7d85b9afb513532cc30f5b51a3f825e
1390]
1391[Add comprehensive testsuite for IntMap
1392Don Stewart <dons@galois.com>**20100831093202
1393 Ignore-this: d455fedbc615e5b63ac488e605550557
1394]
1395[-O2 -fregs-graph is a uniform 10% improvements for IntMap
1396Don Stewart <dons@galois.com>**20100831092956
1397 Ignore-this: 2372cf4be945fe7939d0af94e32c567f
1398]
1399[Missed base case for updateAt worker. Spotted by Jan-Willem Maessen
1400Don Stewart <dons@galois.com>**20100829163329
1401 Ignore-this: b8daf1c55c163c16f50c3b54cca2dba1
1402]
1403[Major bump (new functions, clarified strictness properties, vastly better performance)
1404Don Stewart <dons@galois.com>**20100829122628
1405 Ignore-this: 9bfbc58ecaa24a86be37b8c4cb043457
1406]
1407[Add two new functions: foldlWithKey' and insertLookupWithKey'
1408Don Stewart <dons@galois.com>**20100829122147
1409 Ignore-this: a2f112653ba38737fe1b38609e06c314
1410 
1411 These two functions use strict accumulators, compared to their existing
1412 counterparts (which are lazy left folds, that appear not to be useful).
1413 Performance is significantly better.
1414 
1415]
1416[Performance improvements to Data.Map
1417Don Stewart <dons@galois.com>**20100829120245
1418 Ignore-this: b4830cddfa6d62e4883f4e0f58ac4e57
1419 
1420 Applied several standard transformations to improve the performance of
1421 code:
1422 
1423     * Worker/wrapper of all recursive functions with constant arguments
1424     * Inlining of all (non-recursive) wrappers
1425     * Consistent use of strict keys
1426 
1427 Average performance improvements across common API (with GHC 6.12.3):
1428 
1429     * Linux / x86_64 / 2.6Ghz i7        : 48%
1430     * Mac OSX 10.5 / x86 / 2 Ghz Xeon   : 36%
1431 
1432 Graphs and raw data: http://is.gd/eJHIE
1433 
1434 This patch is (mostly) orthogonal to the algorithmic changes suggested
1435 by Milan Straka in his HW 2010 paper:
1436 
1437     http://research.microsoft.com/~simonpj/papers/containers/containers.pdf
1438 
1439 Those changes could be added separately, for some additional improvments.
1440 
1441 Work carried out over 28/29th August, 2010 in Utrecht, NL, by Johan Tibell
1442 and Don Stewart.
1443 
1444]
1445[Add a criterion-based benchmark suite for Data.Map
1446Don Stewart <dons@galois.com>**20100829114611
1447 Ignore-this: ec61668f5bcb78bd15b72e2728c01c19
1448 
1449 This adds a criterion-based micro-benchmarking suite for Data.Map. It
1450 can be used to measure performance improvements for individual top-level
1451 functions.
1452 
1453 Examples here: http://is.gd/eJHIE
1454 
1455]
1456[Add a comprehensive testsuite for Data.Map
1457Don Stewart <dons@galois.com>**20100829113545
1458 Ignore-this: 891e7fe6bac3523868714ac1ff51c0a3
1459 
1460 This patch adds a joint quickcheck2 / hunit testsuite, with coverage of
1461 91% of top level functions (remaining features are mostly in instances).
1462 
1463 The coverage data is here:
1464     
1465     http://code.haskell.org/~dons/tests/containers/hpc_index.html
1466 
1467 No bugs were found. It includes unit tests for known past bugs
1468 (balancing).
1469 
1470]
1471[Oops, get the #ifdef symbol correct.
1472Malcolm.Wallace@me.com**20100902081938]
1473[Protect a gratuitous GHC-ism with #ifdefs.
1474Malcolm.Wallace@me.com**20100902081217]
1475[Set Data.Map's delta to 4; fixes #4242
1476Ian Lynagh <igloo@earth.li>**20100815131954]
1477[Add a test for #4242
1478Ian Lynagh <igloo@earth.li>**20100815131856]
1479[Add a local type signature
1480simonpj@microsoft.com**20100730124447
1481 Ignore-this: b581d3f2c80a7a860456d589960f12f2
1482]
1483[Add type signature in local where clause
1484simonpj@microsoft.com**20100727151709
1485 Ignore-this: 5929c4156500b25b280eb414b508c508
1486]
1487[Fix Data.Sequence's breakr, and add a test for it; fixes trac #4157
1488Ian Lynagh <igloo@earth.li>**20100704140627]
1489[Fix proposal #4109: Make Data.Map.insertWith's strictness consistent
1490Ian Lynagh <igloo@earth.li>**20100615133055]
1491[Tweak layout to work with the alternative layout rule
1492Ian Lynagh <igloo@earth.li>**20091129154519]
1493[Disable building Data.Sequence (and dependents) for nhc98.
1494Malcolm.Wallace@cs.york.ac.uk**20091124025653
1495 There is some subtlety of polymorphically recursive datatypes and
1496 type-class defaulting that nhc98's type system barfs over.
1497]
1498[Fix another instance of non-ghc breakage.
1499Malcolm.Wallace@cs.york.ac.uk**20091123092637]
1500[Add #ifdef around ghc-only (<$) as member of Functor class.
1501Malcolm.Wallace@cs.york.ac.uk**20091123085155]
1502[Fix broken code in non-GHC branch of an ifdef.
1503Malcolm.Wallace@cs.york.ac.uk**20091123084824]
1504[doc bugfix: correct description of index argument
1505Ross Paterson <ross@soi.city.ac.uk>**20091028105532
1506 Ignore-this: 9790e7bf422c4cb528722c03cfa4fed9
1507 
1508 As noted by iaefai on the libraries list.
1509 
1510 Please merge to STABLE.
1511]
1512[Bump version to 0.3.0.0
1513Ian Lynagh <igloo@earth.li>**20090920141847]
1514[update base dependency
1515Ross Paterson <ross@soi.city.ac.uk>**20090916073125
1516 Ignore-this: ad382ffc6c6a18c15364e6c072f19edb
1517 
1518 The package uses mkNoRepType and Data.Functor, which were not in the
1519 stable branch of base-4.
1520]
1521[add fast version of <$ for Seq
1522Ross Paterson <ross@soi.city.ac.uk>**20090916072812
1523 Ignore-this: 5a39a7d31d39760ed589790b1118d240
1524]
1525[new methods for Data.Sequence (proposal #3271)
1526Ross Paterson <ross@soi.city.ac.uk>**20090915173324
1527 Ignore-this: cf17bedd709a6ab3448fd718dcdf62e7
1528 
1529 Adds a lot of new methods to Data.Sequence, mostly paralleling those
1530 in Data.List.  Several of these are significantly faster than versions
1531 implemented with the previous public interface.  In particular, replicate
1532 takes O(log n) time and space instead of O(n).
1533 (by Louis Wasserman)
1534]
1535[Fix "Cabal check" warnings
1536Ian Lynagh <igloo@earth.li>**20090811215900]
1537[TAG 2009-06-25
1538Ian Lynagh <igloo@earth.li>**20090625160202]
1539Patch bundle hash:
15403d4657e0658b27e78843624cd0a41a811856d9c9