Ticket #3271: new-methods-for-data_sequence.dpatch

File new-methods-for-data_sequence.dpatch, 41.5 KB (added by LouisWasserman, 5 years ago)

Final version of all methods for Data.Sequence, including sort and sortBy.

Line 
1Wed Jun 24 13:45:17 EDT 2009  wasserman.louis@gmail.com
2  * Ticket #3271: New methods for Data.Sequence
3
4New patches:
5
6[Ticket #3271: New methods for Data.Sequence
7wasserman.louis@gmail.com**20090624174517
8 Ignore-this: 1b9b00fabd8360c3d3c43d3b2779de62
9] {
10hunk ./Data/Sequence.hs 39
11        -- * Construction
12        empty,          -- :: Seq a
13        singleton,      -- :: a -> Seq a
14+       replicate,      -- :: Int -> a -> Seq a
15        (<|),           -- :: a -> Seq a -> Seq a
16        (|>),           -- :: Seq a -> a -> Seq a
17        (><),           -- :: Seq a -> Seq a -> Seq a
18hunk ./Data/Sequence.hs 44
19        fromList,       -- :: [a] -> Seq a
20+       -- ** Sequential construction
21+       iterate,        -- :: Int -> (a -> a) -> a -> Seq a
22+       unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a
23        -- * Deconstruction
24        -- | Additional functions for deconstructing sequences are available
25        -- via the 'Foldable' instance of 'Seq'.
26hunk ./Data/Sequence.hs 59
27        viewl,          -- :: Seq a -> ViewL a
28        ViewR(..),
29        viewr,          -- :: Seq a -> ViewR a
30+       -- ** Scanning
31+       scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a
32+       scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a
33+       scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b
34+       scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a
35+       -- ** Sublists
36+       tails,          -- :: Seq a -> Seq (Seq a)
37+       inits,          -- :: Seq a -> Seq (Seq a)
38+       takeWhile,      -- :: (a -> Bool) -> Seq a -> Seq a
39+       dropWhile,      -- :: (a -> Bool) -> Seq a -> Seq a
40+       span,           -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
41+       break,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
42+       partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
43+       -- ** Sorts
44+       sort,           -- :: Ord a => Seq a -> Seq a
45+       sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a
46        -- ** Indexing
47        index,          -- :: Seq a -> Int -> a
48        adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a
49hunk ./Data/Sequence.hs 84
50        splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)
51        -- * Transformations
52        reverse,        -- :: Seq a -> Seq a
53+       -- ** Zips
54+       zip,            -- :: Seq a -> Seq b -> Seq (a, b)
55+       zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
56+       zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
57+       zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
58+       zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
59+       zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
60 #if TESTING
61        valid,
62 #endif
63hunk ./Data/Sequence.hs 97
64        ) where
65 
66 import Prelude hiding (
67-       null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
68-       reverse)
69+       null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, span,
70+       scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
71+       takeWhile, dropWhile, break, iterate, reverse)
72 import qualified Data.List (foldl')
73 import Control.Applicative (Applicative(..), (<$>))
74 import Control.Monad (MonadPlus(..))
75hunk ./Data/Sequence.hs 119
76 #endif
77 
78 #if TESTING
79-import Control.Monad (liftM, liftM3, liftM4)
80+import Control.Monad (liftM, liftM2, liftM3, liftM4)
81 import Test.QuickCheck
82 #endif
83 
84hunk ./Data/Sequence.hs 125
85 infixr 5 `consTree`
86 infixl 5 `snocTree`
87+infixr 5 `consDigitToTree`
88+infixl 6 `snocDigitToTree`
89 
90 infixr 5 ><
91 infixr 5 <|, :<
92hunk ./Data/Sequence.hs 279
93                        traverse f sf
94 
95 {-# INLINE deep #-}
96-{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
97-{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
98+{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
99+{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
100 deep           :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
101 deep pr m sf   =  Deep (size pr + size m + size sf) pr m sf
102 
103hunk ./Data/Sequence.hs 317
104        foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
105 
106 instance Functor Digit where
107-       fmap = fmapDefault
108+       fmap f (One x) = One (f x)
109+       fmap f (Two x y) = Two (f x) (f y)
110+       fmap f (Three x y z) = Three (f x) (f y) (f z)
111+       fmap f (Four x y z w) = Four (f x) (f y) (f z) (f w)
112 
113 instance Traversable Digit where
114        traverse f (One a) = One <$> f a
115hunk ./Data/Sequence.hs 329
116        traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
117 
118 instance Sized a => Sized (Digit a) where
119-       {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
120-       {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
121-       size xs = foldl (\ i x -> i + size x) 0 xs
122+       size = sizeDigit
123+
124+{-# SPECIALIZE sizeDigit :: Digit (Elem a) -> Int #-}
125+{-# SPECIALIZE sizeDigit :: Digit (Node a) -> Int #-}
126+sizeDigit :: Sized a => Digit a -> Int
127+sizeDigit (One x) = size x
128+sizeDigit (Two x y) = size x + size y
129+sizeDigit (Three x y z) = size x + size y + size z
130+sizeDigit (Four x y z w) = size x + size y + size z + size w
131 
132 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
133 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
134hunk ./Data/Sequence.hs 364
135        foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
136 
137 instance Functor Node where
138-       fmap = fmapDefault
139+       fmap f (Node2 n a b) = Node2 n (f a) (f b)
140+       fmap f (Node3 n a b c) = Node3 n (f a) (f b) (f c)
141 
142 instance Traversable Node where
143        traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
144hunk ./Data/Sequence.hs 425
145 singleton      :: a -> Seq a
146 singleton x    =  Seq (Single (Elem x))
147 
148+-- | /O(log n)/. @replicate n x@ is a sequence of length @n@ with @x@ the value of every element.
149+replicate      :: Int -> a -> Seq a
150+replicate n _ | n < 0 = error "replicate takes a nonnegative integer argument"
151+replicate n x  = Seq (replicateFinger n (Elem x))
152+
153+{-# SPECIALIZE replicateFinger :: Int -> Elem a -> FingerTree (Elem a) #-}
154+{-# SPECIALIZE replicateFinger :: Int -> Node a -> FingerTree (Node a) #-}
155+replicateFinger :: Sized a => Int -> a -> FingerTree a
156+-- Replicates an element in a FingerTree using /O(log n)/ space with careful use of
157+-- node sharing.  The reduction in allocation over @fromList (Prelude.replicate n x)@
158+-- is tremendous.
159+replicateFinger n x = case n of
160+       0       -> Empty
161+       1       -> Single x
162+       2       -> deep one Empty one
163+       3       -> deep two Empty one
164+       4       -> deep two Empty two
165+       5       -> deep three Empty two
166+       6       -> deep three Empty three
167+       7       -> deep four Empty three
168+       8       -> deep four Empty four
169+       _       -> let node = node3 x x x in case (n - 8) `quotRem` 3 of
170+               (q, 0)  -> deep four (replicateFinger q node) four
171+               (q, 1)  -> deep three (replicateFinger (q+1) node) three
172+               (q, _)  -> deep four (replicateFinger (q+1) node) three
173+       where   one = One x             -- Maximize node sharing.
174+               two = Two x x
175+               three = Three x x x
176+               four = Four x x x x
177+
178 -- | /O(1)/. Add an element to the left end of a sequence.
179 -- Mnemonic: a triangle with the single element at the pointy end.
180 (<|)           :: a -> Seq a -> Seq a
181hunk ./Data/Sequence.hs 551
182 appendTree1 xs a Empty =
183        xs `snocTree` a
184 appendTree1 (Single x) a xs =
185-       x `consTree` a `consTree` xs
186+       Two x a `consDigitToTree` xs
187 appendTree1 xs a (Single x) =
188hunk ./Data/Sequence.hs 553
189-       xs `snocTree` a `snocTree` x
190+       xs `snocDigitToTree` Two a x
191 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
192        Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
193 
194hunk ./Data/Sequence.hs 593
195 
196 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
197 appendTree2 Empty a b xs =
198-       a `consTree` b `consTree` xs
199+       Two a b `consDigitToTree` xs
200 appendTree2 xs a b Empty =
201hunk ./Data/Sequence.hs 595
202-       xs `snocTree` a `snocTree` b
203+       xs `snocDigitToTree` Two a b
204 appendTree2 (Single x) a b xs =
205hunk ./Data/Sequence.hs 597
206-       x `consTree` a `consTree` b `consTree` xs
207+       Three x a b `consDigitToTree` xs
208 appendTree2 xs a b (Single x) =
209hunk ./Data/Sequence.hs 599
210-       xs `snocTree` a `snocTree` b `snocTree` x
211+       xs `snocDigitToTree` Three a b x
212 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
213        Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
214 
215hunk ./Data/Sequence.hs 639
216 
217 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
218 appendTree3 Empty a b c xs =
219-       a `consTree` b `consTree` c `consTree` xs
220+       Three a b c `consDigitToTree` xs
221 appendTree3 xs a b c Empty =
222hunk ./Data/Sequence.hs 641
223-       xs `snocTree` a `snocTree` b `snocTree` c
224+       xs `snocDigitToTree` Three a b c
225 appendTree3 (Single x) a b c xs =
226hunk ./Data/Sequence.hs 643
227-       x `consTree` a `consTree` b `consTree` c `consTree` xs
228+       Four x a b c `consDigitToTree` xs
229 appendTree3 xs a b c (Single x) =
230hunk ./Data/Sequence.hs 645
231-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
232+       xs `snocDigitToTree` Four a b c x
233 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
234        Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
235 
236hunk ./Data/Sequence.hs 685
237 
238 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
239 appendTree4 Empty a b c d xs =
240-       a `consTree` b `consTree` c `consTree` d `consTree` xs
241+       Four a b c d `consDigitToTree` xs
242 appendTree4 xs a b c d Empty =
243hunk ./Data/Sequence.hs 687
244-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
245+       xs `snocDigitToTree` Four a b c d
246 appendTree4 (Single x) a b c d xs =
247hunk ./Data/Sequence.hs 689
248-       x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
249+       x `consTree` Four a b c d `consDigitToTree` xs
250 appendTree4 xs a b c d (Single x) =
251hunk ./Data/Sequence.hs 691
252-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
253+       xs `snocDigitToTree` Four a b c d `snocTree` x
254 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
255        Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
256 
257hunk ./Data/Sequence.hs 729
258 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
259        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
260 
261+-- Cons and snoc for entire digits at once.  This code was automatically generated.
262+-- For general internal use, this is considerably more efficient than repeated use of
263+-- consTree or snocTree, which end up case'ing the appropriate digit once for every
264+-- insertion, while this code only does it once.
265+
266+{-# SPECIALIZE consDigitToTree :: Digit (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
267+{-# SPECIALIZE consDigitToTree :: Digit (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-}
268+consDigitToTree :: Sized a => Digit a -> FingerTree a -> FingerTree a
269+consDigitToTree dig Empty
270+       = digitToTree dig
271+consDigitToTree dig (Single a)
272+       = Deep (size dig + size a) dig Empty (One a)
273+consDigitToTree dig@(One a) (Deep n (One x) m sf)
274+       = Deep (n + size dig) (Two a x) m sf
275+consDigitToTree dig@(One a) (Deep n (Two x y) m sf)
276+       = Deep (n + size dig) (Three a x y) m sf
277+consDigitToTree dig@(One a) (Deep n (Three x y z) m sf)
278+       = Deep (n + size dig) (Four a x y z) m sf
279+consDigitToTree dig@(One a) (Deep n (Four x y z w) m sf)
280+       = Deep (n + size dig) (Two a x) ((node3 y z w) `consTree` m) sf
281+consDigitToTree dig@(Two a b) (Deep n (One x) m sf)
282+       = Deep (n + size dig) (Three a b x) m sf
283+consDigitToTree dig@(Two a b) (Deep n (Two x y) m sf)
284+       = Deep (n + size dig) (Four a b x y) m sf
285+consDigitToTree dig@(Two a b) (Deep n (Three x y z) m sf)
286+       = Deep (n + size dig) (Two a b) ((node3 x y z) `consTree` m) sf
287+consDigitToTree dig@(Two a b) (Deep n (Four x y z w) m sf)
288+       = Deep (n + size dig) (Three a b x) ((node3 y z w) `consTree` m) sf
289+consDigitToTree dig@(Three a b c) (Deep n (One x) m sf)
290+       = Deep (n + size dig) (Four a b c x) m sf
291+consDigitToTree dig@(Three a b c) (Deep n (Two x y) m sf)
292+       = Deep (n + size dig) (Two a b) ((node3 c x y) `consTree` m) sf
293+consDigitToTree dig@(Three a b c) (Deep n (Three x y z) m sf)
294+       = Deep (n + size dig) (Three a b c) ((node3 x y z) `consTree` m) sf
295+consDigitToTree dig@(Three a b c) (Deep n (Four x y z w) m sf)
296+       = Deep (n + size dig) (One a) (Two (node3 b c x) (node3 y z w) `consDigitToTree` m) sf
297+consDigitToTree dig@(Four a b c d) (Deep n (One x) m sf)
298+       = Deep (n + size dig) (Two a b) ((node3 c d x) `consTree` m) sf
299+consDigitToTree dig@(Four a b c d) (Deep n (Two x y) m sf)
300+       = Deep (n + size dig) (Three a b c) ((node3 d x y) `consTree` m) sf
301+consDigitToTree dig@(Four a b c d) (Deep n (Three x y z) m sf)
302+       = Deep (n + size dig) (One a) (Two (node3 b c d) (node3 x y z) `consDigitToTree` m) sf
303+consDigitToTree dig@(Four a b c d) (Deep n (Four x y z w) m sf)
304+       = Deep (n + size dig) (Two a b) (Two (node3 c d x) (node3 y z w) `consDigitToTree` m) sf
305+
306+{-# SPECIALIZE snocDigitToTree :: FingerTree (Elem a) -> Digit (Elem a) -> FingerTree (Elem a) #-}
307+{-# SPECIALIZE snocDigitToTree :: FingerTree (Node a) -> Digit (Node a) -> FingerTree (Node a) #-}
308+snocDigitToTree :: Sized a => FingerTree a -> Digit a -> FingerTree a
309+snocDigitToTree Empty dig
310+       = digitToTree dig
311+snocDigitToTree (Single a) dig
312+       = Deep (size a + size dig) (One a) Empty dig
313+snocDigitToTree (Deep n pr m (One a)) dig@(One x)
314+       = Deep (n + size dig) pr m (Two a x)
315+snocDigitToTree (Deep n pr m (One a)) dig@(Two x y)
316+       = Deep (n + size dig) pr m (Three a x y)
317+snocDigitToTree (Deep n pr m (One a)) dig@(Three x y z)
318+       = Deep (n + size dig) pr m (Four a x y z)
319+snocDigitToTree (Deep n pr m (One a)) dig@(Four x y z w)
320+       = Deep (n + size dig) pr (m `snocTree` (node3 a x y)) (Two z w)
321+snocDigitToTree (Deep n pr m (Two a b)) dig@(One x)
322+       = Deep (n + size dig) pr m (Three a b x)
323+snocDigitToTree (Deep n pr m (Two a b)) dig@(Two x y)
324+       = Deep (n + size dig) pr m (Four a b x y)
325+snocDigitToTree (Deep n pr m (Two a b)) dig@(Three x y z)
326+       = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Two y z)
327+snocDigitToTree (Deep n pr m (Two a b)) dig@(Four x y z w)
328+       = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Three y z w)
329+snocDigitToTree (Deep n pr m (Three a b c)) dig@(One x)
330+       = Deep (n + size dig) pr m (Four a b c x)
331+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Two x y)
332+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two x y)
333+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Three x y z)
334+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three x y z)
335+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Four x y z w)
336+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 x y z)) (One w)
337+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(One x)
338+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two d x)
339+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Two x y)
340+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three d x y)
341+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Three x y z)
342+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (One z)
343+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Four x y z w)
344+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (Two z w)
345+
346+-- | Builds a sequence from a seed value.  Takes time linear in the number of generated elements.  /WARNING: If the number of generated elements is infinite, this method will not terminate./
347+unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
348+unfoldr f b = unfoldr' empty b where
349+       -- uses tail recursion rather than, for instance, the List implementation.
350+       unfoldr' as b = case f b of
351+               Nothing         -> as
352+               Just (a, b')    -> unfoldr' (as |> a) b'
353+
354+-- | /O(n)/.  Constructs a sequence by repeated application of a function to a seed value.
355+--
356+-- > iterate n f x = fromList (Prelude.take n (Prelude.iterate f x))
357+iterate :: Int -> (a -> a) -> a -> Seq a
358+-- borrows the structure of the sequence from replicate and preserves it with mapAccumL
359+iterate n f x = n `seq` snd (mapAccumL iterate' x (replicate n ())) where
360+       iterate' y _ = let y' = f y in (y', y)
361+
362 ------------------------------------------------------------------------
363 -- Deconstruction
364 ------------------------------------------------------------------------
365hunk ./Data/Sequence.hs 964
366 viewRTree (Deep s pr m (Four w x y z)) =
367        Just2 (Deep (s - size z) pr m (Three w x y)) z
368 
369+------------------------------------------------------------------------
370+-- Scans
371+--
372+-- These are not particularly complex applications of the Traversable
373+-- functor, though making the correspondence with Data.List exact
374+-- requires the use of (<|) and (|>).
375+--
376+-- Note that save for the single (<|) or (|>), we maintain the original
377+-- structure of the Seq, not having to do any restructuring of our own.
378+--
379+-- wasserman.louis@gmail.com, 5/23/09
380+------------------------------------------------------------------------
381+
382+-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced values from the left:
383+--
384+-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
385+scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
386+scanl f z0 xs = z0 <| snd (mapAccumL accum z0 xs)
387+       where accum x z = let x' = f x z in (x', x')
388+
389+-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
390+--
391+-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
392+scanl1 :: (a -> a -> a) -> Seq a -> Seq a
393+scanl1 f xs = case viewl xs of
394+       EmptyL          -> error "scanl1 takes a nonempty sequence as an argument"
395+       x :< xs'        -> scanl f x xs'
396+
397+-- | 'scanr' is the right-to-left dual of 'scanl'.
398+scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
399+scanr f z0 xs = snd (mapAccumR accum z0 xs) |> z0
400+       where accum z x = let z' = f x z in (z', z')
401+
402+-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
403+scanr1 :: (a -> a -> a) -> Seq a -> Seq a
404+scanr1 f xs = case viewr xs of
405+       EmptyR          -> error "scanr1 takes a nonempty sequence as an argument"
406+       xs' :> x        -> scanr f x xs'
407+
408 -- Indexing
409 
410 -- | /O(log(min(i,n-i)))/. The element at the specified position,
411hunk ./Data/Sequence.hs 1153
412 splitAt i (Seq xs)     =  (Seq l, Seq r)
413   where        (l, r)          =  split i xs
414 
415+-- | /O(n)/.  Returns a sequence of all suffixes of this sequence, longest first.  For example,
416+--
417+-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
418+--
419+-- The suffixes are computed lazily from left to right.
420+tails                  :: Seq a -> Seq (Seq a)
421+-- Observation: If one value every n/log n values were computed with an application of drop to the original sequence,
422+-- and the remaining values were computed from these, viewing any individual tail would cost O(log n) and viewing every tail
423+-- would cost O(n).  This is probably an overcomplication, though.
424+tails xs               = scanl tail' xs xs where
425+       tail' ys _ = case viewl ys of
426+               _ :< ys'        -> ys'
427+               _               -> error "Invariant failure in Data.Sequence.tails" -- should never happen
428+
429+-- | /O(n)/.  Returns a sequence of all prefixes of this sequence, shortest first. For example,
430+--
431+-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
432+--
433+-- The prefixes are computed lazily from left to right. 
434+inits                  :: Seq a -> Seq (Seq a)
435+inits                  = scanl (|>) empty
436+
437 split :: Int -> FingerTree (Elem a) ->
438        (FingerTree (Elem a), FingerTree (Elem a))
439 split i Empty  = i `seq` (Empty, Empty)
440hunk ./Data/Sequence.hs 1205
441        spm     = spr + size m
442        im      = i - spr
443 
444+{-# SPECIALIZE pullL :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Elem a) #-}
445+{-# SPECIALIZE pullL :: Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node a) #-}
446+pullL :: Sized a => Digit a -> FingerTree (Node a) -> FingerTree a
447+pullL pr m = case viewRTree m of
448+       Nothing2        -> digitToTree pr
449+       Just2 m' sf     -> Deep (size pr + size m) pr m' (nodeToDigit sf)
450+
451+{-# SPECIALIZE pullR :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
452+{-# SPECIALIZE pullR :: FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
453+pullR :: Sized a => FingerTree (Node a) -> Digit a -> FingerTree a
454+pullR m sf = case viewLTree m of
455+       Nothing2        -> digitToTree sf
456+       Just2 pr m'     -> Deep (size sf + size m) (nodeToDigit pr) m' sf
457+
458+{-# SPECIALIZE pull :: FingerTree (Node (Elem a)) -> FingerTree (Elem a) #-}
459+{-# SPECIALIZE pull :: FingerTree (Node (Node a)) -> FingerTree (Node a) #-}
460+-- Pulls a left and a right digit out of a deep finger tree to make a new tree.  pull t == deepLR Nothing t Nothing.
461+pull :: Sized a => FingerTree (Node a) -> FingerTree a
462+pull t = case viewLTree t of
463+       Nothing2        -> Empty
464+       Just2 pr t'     -> pullL (nodeToDigit pr) t'
465+
466 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
467 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
468 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
469hunk ./Data/Sequence.hs 1230
470-deepL Nothing m sf     = case viewLTree m of
471-       Nothing2        -> digitToTree sf
472-       Just2 a m'      -> Deep (size m + size sf) (nodeToDigit a) m' sf
473+deepL Nothing m sf     = pullR m sf
474 deepL (Just pr) m sf   = deep pr m sf
475 
476 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
477hunk ./Data/Sequence.hs 1236
478 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
479 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
480-deepR pr m Nothing     = case viewRTree m of
481-       Nothing2        -> digitToTree pr
482-       Just2 m' a      -> Deep (size pr + size m) pr m' (nodeToDigit a)
483+deepR pr m Nothing     = pullL pr m
484 deepR pr m (Just sf)   = deep pr m sf
485 
486hunk ./Data/Sequence.hs 1239
487+{-# SPECIALIZE INLINE deepLR :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
488+{-# SPECIALIZE INLINE deepLR :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
489+deepLR :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
490+deepLR (Just pr) m Nothing = pullL pr m
491+deepLR (Just pr) m (Just sf) = deep pr m sf
492+deepLR Nothing m (Just sf) = pullR m sf
493+deepLR Nothing m Nothing = pull m
494+
495 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
496 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
497 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
498hunk ./Data/Sequence.hs 1284
499        sab     = sa + size b
500        sabc    = sab + size c
501 
502+-- | /O(i)/ where /i/ is the breakpoint index.  'takeWhile', applied to a predicate @p@ and a sequence @xs@, returns the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@.
503+takeWhile :: (a -> Bool) -> Seq a -> Seq a
504+takeWhile p xs = fst (span p xs)
505+
506+-- | /O(i)/ where /i/ is the breakpoint index.  @'dropWhile' p xs@ returns the suffix remaining after @takeWhile p xs@.
507+dropWhile :: (a -> Bool) -> Seq a -> Seq a
508+dropWhile p xs = snd (span p xs)
509+
510+-- | /O(i)/ where /i/ is the breakpoint index.  'span', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that satisfy @p@ and the second element is the remainder of the sequence.
511+span :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
512+span p xs = splitAt ix xs
513+       where   indexed = snd (mapAccumL (\ i x -> i `seq` (i + 1, (x, i))) 0 xs)
514+               ix = foldr (\ (x, i) i' -> if p x then i' else i) (length xs) indexed
515+
516+-- | /O(i)/ where /i/ is the breakpoint index.  'break', applied to a predicate @p@ and a sequence @xs@, returns a tuple whose first element is the longest prefix (possibly empty) of @xs@ of elements that /do not satisfy/ @p@ and the second element is the remainder of the sequence.
517+break :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
518+break p xs = span (not . p) xs
519+
520+-- | /O(n)/.  The 'partition' function takes a predicate @p@ and a sequence @xs@ and returns sequences of those elements which do and do not satisfy the predicate.
521+partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
522+partition p (Seq xs) = case partitionTree (\ (Elem x) -> p x) xs of
523+       (xsT, xsF) -> (Seq xsT, Seq xsF)
524+
525+{-# SPECIALIZE partitionTree :: (Elem a -> Bool) -> FingerTree (Elem a) -> (FingerTree (Elem a), FingerTree (Elem a)) #-}
526+partitionTree :: Sized a => (a -> Bool) -> FingerTree a -> (FingerTree a, FingerTree a)
527+partitionTree _ Empty  = (Empty, Empty)
528+partitionTree p (Single x)
529+       | p x           = (Single x, Empty)
530+       | otherwise     = (Empty, Single x)
531+partitionTree p (Deep _ pr m sf) = case (partitionDigit p pr, partitionDigit p sf, partitionTree p (pull m)) of
532+       ((prT, prF), (sfT, sfF), (mT, mF)) -> (combine prT mT sfT, combine prF mF sfF)
533+       where   combineL pr m = foldr consDigitToTree m pr -- Golly gee, possibly consing a Maybe value onto a tree
534+               combineR m sf = foldl snocDigitToTree m sf -- is a fold!  Whoaaaaa!
535+               combine pr m sf = pr `combineL` m `combineR` sf
536+
537+partitionDigit :: (a -> Bool) -> Digit a -> (Maybe (Digit a), Maybe (Digit a))
538+partitionDigit p (One a) = case (p a) of
539+       (False)         -> (Nothing, Just (One a))
540+       (True)          -> (Just (One a), Nothing)
541+partitionDigit p (Two a b) = case (p a, p b) of
542+       (False, False)          -> (Nothing, Just (Two a b))
543+       (False, True)           -> (Just (One b), Just (One a))
544+       (True, False)           -> (Just (One a), Just (One b))
545+       (True, True)            -> (Just (Two a b), Nothing)
546+partitionDigit p (Three a b c) = case (p a, p b, p c) of
547+       (False, False, False)           -> (Nothing, Just (Three a b c))
548+       (False, False, True)            -> (Just (One c), Just (Two a b))
549+       (False, True, False)            -> (Just (One b), Just (Two a c))
550+       (False, True, True)             -> (Just (Two b c), Just (One a))
551+       (True, False, False)            -> (Just (One a), Just (Two b c))
552+       (True, False, True)             -> (Just (Two a c), Just (One b))
553+       (True, True, False)             -> (Just (Two a b), Just (One c))
554+       (True, True, True)              -> (Just (Three a b c), Nothing)
555+partitionDigit p (Four a b c d) = case (p a, p b, p c, p d) of
556+       (False, False, False, False)            -> (Nothing, Just (Four a b c d))
557+       (False, False, False, True)             -> (Just (One d), Just (Three a b c))
558+       (False, False, True, False)             -> (Just (One c), Just (Three a b d))
559+       (False, False, True, True)              -> (Just (Two c d), Just (Two a b))
560+       (False, True, False, False)             -> (Just (One b), Just (Three a c d))
561+       (False, True, False, True)              -> (Just (Two b d), Just (Two a c))
562+       (False, True, True, False)              -> (Just (Two b c), Just (Two a d))
563+       (False, True, True, True)               -> (Just (Three b c d), Just (One a))
564+       (True, False, False, False)             -> (Just (One a), Just (Three b c d))
565+       (True, False, False, True)              -> (Just (Two a d), Just (Two b c))
566+       (True, False, True, False)              -> (Just (Two a c), Just (Two b d))
567+       (True, False, True, True)               -> (Just (Three a c d), Just (One b))
568+       (True, True, False, False)              -> (Just (Two a b), Just (Two c d))
569+       (True, True, False, True)               -> (Just (Three a b d), Just (One c))
570+       (True, True, True, False)               -> (Just (Three a b c), Just (One d))
571+       (True, True, True, True)                -> (Just (Four a b c d), Nothing)
572+
573 ------------------------------------------------------------------------
574 -- Lists
575 ------------------------------------------------------------------------
576hunk ./Data/Sequence.hs 1381
577                (reverseTree (reverseNode f) m)
578                (reverseDigit f pr)
579 
580+{-# INLINE reverseDigit #-}
581 reverseDigit :: (a -> a) -> Digit a -> Digit a
582 reverseDigit f (One a) = One (f a)
583 reverseDigit f (Two a b) = Two (f b) (f a)
584hunk ./Data/Sequence.hs 1392
585 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
586 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
587 
588+------------------------------------------------------------------------
589+-- Zipping
590+--
591+-- We implement zipping on sequences by zipping left and right digits simultaneously and
592+-- processing excess appropriately.  This allows several elements to be ``zipped''
593+-- in a single go, which is significantly faster than it might be for a linked-list approach,
594+-- where we'd have to do at least one dereference for each element.
595+------------------------------------------------------------------------
596+
597+-- | /O(n)/.  'zip' takes two sequences and returns a sequence of corresponding pairs. 
598+-- If one input is short, excess elements of the longer sequence are discarded.
599+zip :: Seq a -> Seq b -> Seq (a, b)
600+zip = zipWith (,)
601+
602+-- | /O(n)/.  'zipWith' generalizes 'zip' by zipping with the function given as the first argument,
603+-- instead of a tupling function.  For example, @zipWith (+)@ is applied to two sequences to take
604+-- the sequence of corresponding sums.
605+zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
606+zipWith f s1 s2 = zipTrunc f (trunc s1) (trunc s2)
607+       where   n = length s1 `min` length s2
608+               trunc = take n
609+
610+zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
611+zip3 = zipWith3 (,,)
612+
613+zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
614+zipWith3 f s1 s2 s3 = zipTrunc ($) (zipTrunc f (trunc s1) (trunc s2)) (trunc s3)
615+       where   n = length s1 `min` length s2 `min` length s3
616+               trunc = take n
617+
618+zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
619+zip4 = zipWith4 (,,,)
620+
621+zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
622+zipWith4 f s1 s2 s3 s4 = ((zipTrunc f (trunc s1) (trunc s2)) `zipApply` trunc s3) `zipApply` trunc s4
623+       where   n = length s1 `min` length s2 `min` length s3 `min` length s4
624+               trunc = take n
625+               zipApply = zipTrunc ($)
626+
627+-- assumes its arguments are the same length
628+zipTrunc :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
629+zipTrunc f (Seq a) (Seq b) = Seq (zipWithTree (\ (Elem x) (Elem y) -> Elem (f x y)) a b)
630+
631+-- We maintain as an invariant that t1 and t2 have the same size, guaranteeing that they will always
632+-- have the same FingerTree constructor.  We construct the zipped sequence from both sides at once,
633+-- and at each stage "zip" the left and right digits of t1 and t2 and recurse, handling excess appropriately.
634+zipWithTree :: (Elem a -> Elem b -> Elem c) -> FingerTree (Elem a) -> FingerTree (Elem b) ->
635+       FingerTree (Elem c)
636+zipWithTree f = zipper where
637+       Empty `zipper` Empty =
638+               Empty
639+       Single a `zipper` Single x =
640+               Single (a `f` x)
641+       Deep _ l1 m1 r1 `zipper` Deep _ l2 m2 r2 = case (zipL f l1 l2, zipR f r1 r2) of
642+               ((lZip, l1', l2'), (rZip, r1', r2')) ->
643+                       lZip `consDigitToTree` deepLR l1' m1 r1' `zipper` deepLR l2' m2 r2' `snocDigitToTree` rZip
644+       _ `zipper` _ = error "Invariant failure in Data.Sequence.zipWith"
645+
646+{-# INLINE zipL #-}
647+-- Zips two digits from the left side, returning the zipped result and remainders.
648+zipL :: (a -> b -> c) -> Digit a -> Digit b -> (Digit c, Maybe (Digit a), Maybe (Digit b))
649+zipL f (One a) (One x)                         = (One (a `f` x), Nothing, Nothing)
650+zipL f (One a) (Two x y)               = (One (a `f` x), Nothing, Just (One y))
651+zipL f (One a) (Three x y z)           = (One (a `f` x), Nothing, Just (Two y z))
652+zipL f (One a) (Four x y z w)          = (One (a `f` x), Nothing, Just (Three y z w))
653+zipL f (Two a b) (One x)               = (One (a `f` x), Just (One b), Nothing)
654+zipL f (Two a b) (Two x y)             = (Two (a `f` x) (b `f` y), Nothing, Nothing)
655+zipL f (Two a b) (Three x y z)                 = (Two (a `f` x) (b `f` y), Nothing, Just (One z))
656+zipL f (Two a b) (Four x y z w)        = (Two (a `f` x) (b `f` y), Nothing, Just (Two z w))
657+zipL f (Three a b c) (One x)           = (One (a `f` x), Just (Two b c), Nothing)
658+zipL f (Three a b c) (Two x y)                 = (Two (a `f` x) (b `f` y), Just (One c), Nothing)
659+zipL f (Three a b c) (Three x y z)     = (Three (a `f` x) (b `f` y) (c `f` z), Nothing, Nothing)
660+zipL f (Three a b c) (Four x y z w)    = (Three (a `f` x) (b `f` y) (c `f` z), Nothing, Just (One w))
661+zipL f (Four a b c d) (One x)          = (One (a `f` x), Just (Three b c d), Nothing)
662+zipL f (Four a b c d) (Two x y)        = (Two (a `f` x) (b `f` y), Just (Two c d), Nothing)
663+zipL f (Four a b c d) (Three x y z)    = (Three (a `f` x) (b `f` y) (c `f` z), Just (One d), Nothing)
664+zipL f (Four a b c d) (Four x y z w)   = (Four (a `f` x) (b `f` y) (c `f` z) (d `f` w), Nothing, Nothing)
665+
666+-- Zips two digits from the right, returning the zipped result and both remainders.
667+zipR :: (a -> b -> c) -> Digit a -> Digit b -> (Digit c, Maybe (Digit a), Maybe (Digit b))
668+zipR f (One a) (One x)                         = (One (a `f` x), Nothing, Nothing)
669+zipR f (One a) (Two x y)               = (One (a `f` y), Nothing, Just (One x))
670+zipR f (One a) (Three x y z)           = (One (a `f` z), Nothing, Just (Two x y))
671+zipR f (One a) (Four x y z w)          = (One (a `f` w), Nothing, Just (Three x y z))
672+zipR f (Two a b) (One x)               = (One (b `f` x), Just (One a), Nothing)
673+zipR f (Two a b) (Two x y)             = (Two (a `f` x) (b `f` y), Nothing, Nothing)
674+zipR f (Two a b) (Three x y z)         = (Two (a `f` y) (b `f` z), Nothing, Just (One x))
675+zipR f (Two a b) (Four x y z w)        = (Two (a `f` z) (b `f` w), Nothing, Just (Two x y))
676+zipR f (Three a b c) (One x)           = (One (c `f` x), Just (Two a b), Nothing)
677+zipR f (Three a b c) (Two x y)                 = (Two (b `f` x) (c `f` y), Just (One a), Nothing)
678+zipR f (Three a b c) (Three x y z)     = (Three (a `f` x) (b `f` y) (c `f` z), Nothing, Nothing)
679+zipR f (Three a b c) (Four x y z w)    = (Three (a `f` y) (b `f` z) (c `f` w), Nothing, Just (One x))
680+zipR f (Four a b c d) (One x)          = (One (d `f` x), Just (Three a b c), Nothing)
681+zipR f (Four a b c d) (Two x y)        = (Two (c `f` x) (d `f` y), Just (Two a b), Nothing)
682+zipR f (Four a b c d) (Three x y z)    = (Three (b `f` x) (c `f` y) (d `f` z), Just (One a), Nothing)
683+zipR f (Four a b c d) (Four x y z w)   = (Four (a `f` x) (b `f` y) (c `f` z) (d `f` w), Nothing, Nothing)
684+
685+------------------------------------------------------------------------
686+-- Sorting
687+--
688+-- After exhaustive examination, I decided that sophisticated attempts to exploit the structure of
689+-- finger trees for a sophisticated merge sort were inevitably slower than the plain and simple
690+-- approach taken by Data.List.  Nevertheless, some improvements are feasible.
691+-- Here small, finite blocks of elements are sorted and used as seeds to merge recursively.
692+-- These small, finite blocks are left and right digits, internally sorted and then merged.
693+-- After some careful tuning, GHC's optimizer almost completely inlines the procedures for
694+-- sorting these finite lists.
695+--
696+-- Much of this code was automatically generated.
697+------------------------------------------------------------------------
698+
699+-- | /O(n log n)/.  Sorts the specified 'Seq' by the default ordering.  The sort is not stable.  For a stable sort, convert to a list and use 'Data.List.sort', which is very nearly as fast.
700+sort :: Ord a => Seq a -> Seq a
701+sort = sortBy compare
702+
703+-- | /O(n log n)/.  A generalization of 'sort', 'sortBy' takes an arbitrary comparator and sorts the specified sequence.  The sort is not stable.  For a stable sort, convert to a list and use 'Data.List.sortBy', which is approximately as fast.  (Note: Benchmarks indicate that the two methods take roughly the same average time, but this implementation is considerably more consistent in its speed.)
704+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
705+sortBy cmp (Seq (Deep _ pr m sf)) = merger ((mrg `on` sortDigit cmp) pr sf : wrap' m) where
706+       sortN = sortNode cmp
707+
708+       wrap' Empty = []
709+       wrap' (Single n) = [toList (sortN n)]
710+       wrap' (Deep _ pr m sf) = case zipL (mergeNode cmp `on` sortN) pr sf of
711+               (z, pr', sf')   -> foldr (:) (wrap' (deepLR pr' m sf')) z
712+
713+       merger [] = empty
714+       merger [xs] = fromList xs
715+       merger xss = merger (mergePairs xss)
716+       mergePairs (xs:ys:zss) = mrg xs ys:mergePairs zss
717+       mergePairs xss = xss
718+       mrg = mergeList cmp
719+sortBy _ xs = xs
720+
721+on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
722+f `on` g = \ x y -> f (g x) (g y)
723+
724+-- Sorts the elements of a Digit.  Used only two times in any call to sortBy, but nevertheless necessary.
725+-- (Note: Makes an optimal number of comparisons.)
726+sortDigit :: (a -> a -> Ordering) -> Digit (Elem a) -> [a]
727+sortDigit cmp = sortDigit' where
728+       {-# NOINLINE order2 #-}
729+       order2 p q
730+               | cmp p q == GT = [q,p]
731+               | otherwise     = [p,q]
732+       order = orderPair cmp
733+       p < q = cmp p q == LT
734+       sortDigit' (One (Elem x))
735+               = [x]
736+       sortDigit' (Two (Elem p) (Elem q))
737+               = order2 p q
738+       sortDigit' (Three (Elem p) (Elem q) (Elem r)) = case order p q of
739+               (p', q')        -> if r < p' then [r,p',q'] else p':order2 q' r
740+       sortDigit' (Four (Elem p) (Elem q) (Elem r) (Elem s)) = case (order p q, order r s) of
741+               ((a, b), (x, y))
742+                       | a < x         -> a:if b < x then [b,x,y] else x:order2 b y
743+                       | otherwise     -> x:if a < y then a:order2 b y else [y,a,b]
744+
745+{-# INLINE sortNode #-}
746+-- Convenience method to sort nodes.
747+sortNode :: (a -> a -> Ordering) -> Node (Elem a) -> Node a
748+sortNode cmp (Node2 n (Elem a) (Elem b)) = uncurry (Node2 n) $! orderPair cmp a b
749+sortNode cmp (Node3 n (Elem a) (Elem b) (Elem c)) = case orderPair cmp a b of
750+       (a',b') | cmp c b' == GT        -> Node3 n a' b' c
751+               | cmp c a' == GT        -> Node3 n a' c b'
752+               | otherwise             -> Node3 n c a' b'
753+
754+orderPair :: (a -> a -> Ordering) -> a -> a -> (a, a)
755+orderPair cmp x y
756+       | cmp y x == LT = (y, x)
757+       | otherwise     = (x, y)
758+
759+-- Merges two sorted lists.
760+{-# INLINE mergeList #-}
761+mergeList :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
762+mergeList cmp = mergeList' where
763+       mergeList' xs@(x:xs') ys@(y:ys')
764+               | cmp y x == LT = y:mergeList' xs ys'
765+               | otherwise     = x:mergeList' ys xs'
766+       mergeList' xs [] = xs
767+       mergeList' [] ys = ys
768+
769+-- Merges two sorted nodes into a list very quickly.
770+mergeNode :: (a -> a -> Ordering) -> Node a -> Node a -> [a]
771+mergeNode cmp = mergeNode' where
772+       p < q = cmp p q == LT
773+       order2 p q = if p < q then [p,q] else [q,p]
774+       merge22 a b x y
775+               | a < x         = a:if b < x then [b, x, y] else x:order2 b y
776+               | otherwise     = x:if a < y then a:order2 b y else [y, a, b]
777+       merge23 a b x y z       -- note the binary search in the first case!
778+               | a < x = a:if b < y    then if b < x then [b, x, y, z] else [x, b, y, z]
779+                                       else x:y:order2 b z
780+               | otherwise = x:merge22 a b y z
781+       merge33 a b c x y z
782+               | a < x         = a:merge23 b c x y z
783+               | otherwise     = x:merge23 y z a b c
784+       mergeNode' (Node2 _ a b) (Node2 _ x y) = merge22 a b x y
785+       mergeNode' (Node2 _ a b) (Node3 _ x y z) = merge23 a b x y z
786+       mergeNode' (Node3 _ a b c) (Node2 _ x y) = merge23 x y a b c
787+       mergeNode' (Node3 _ a b c) (Node3 _ x y z) = merge33 a b c x y z
788+
789 #if TESTING
790 
791 ------------------------------------------------------------------------
792}
793
794Context:
795
796[Use left/right rather than old/new to describe the arguments to unionWithKey
797Ian Lynagh <igloo@earth.li>**20090208192132
798 Fixes trac #3002.
799]
800[help nhc98 by making import decl more explicit
801Malcolm.Wallace@cs.york.ac.uk**20090203142144]
802[Add instance Data.Traversable for IntMap
803Matti Niemenmaa <matti.niemenmaa+darcs@iki.fi>**20090116190353
804 Ignore-this: df88a286935926aecec3f8a5dd291699
805]
806[Require Cabal version >= 1.6
807Ian Lynagh <igloo@earth.li>**20090122011256]
808[Add "bug-reports" and "source-repository" info to the Cabal file
809Ian Lynagh <igloo@earth.li>**20090121182106]
810[Fix warnings in containers
811Ian Lynagh <igloo@earth.li>**20090116200251]
812[optimize IntMap/IntSet findMin/findMax
813sedillard@gmail.com**20081002152055]
814[O(n) fromAscList IntSet / IntMap
815sedillard@gmail.com**20080521195941
816 
817 Added algorithm by Scott Dillard and Bertram Felgenhauer to build IntSets and
818 IntMaps from sorted input in linear time. Also changed quickcheck prop_Ordered
819 (no longer a tautology!) to include negative and duplicate keys.
820 
821]
822[correct type for IntMap.intersectionWith[Key]
823sedillard@gmail.com**20081002144828]
824[Export mapAccumRWithKey from Map and IntMap (Trac #2769)
825matti.niemenmaa+darcs@iki.fi**20081210160205]
826[Bump the version number to 0.2.0.1, to work-around cabal-install problems
827Ian Lynagh <igloo@earth.li>**20081212201829]
828[Fix #2760: change mkNorepType to mkNoRepType
829'Jose Pedro Magalhaes <jpm@cs.uu.nl>'**20081202083424]
830[Doc fix, from hackage trac #378
831Ian Lynagh <igloo@earth.li>**20081024143949]
832[import Data.Data instead of Data.Generics.*, eliminating the dependency on syb
833Ross Paterson <ross@soi.city.ac.uk>**20081005002559]
834[fixed typo in highestBitMask
835sedillard@gmail.com**20081002215438]
836[export Data.Map.toDescList, foldlWithKey, and foldrWithKey (trac ticket 2580)
837qdunkan@gmail.com**20080922213200
838 
839 toDescList was previously implemented, but not exported.
840 
841 foldlWithKey was previously implemented, but not exported.  It can be used to
842 implement toDescList.
843 
844 foldrWithKey is already exported as foldWithKey, but foldrWithKey is explicitly
845 the mirror of foldlWithKey, and foldWithKey kept for compatibility.
846]
847[Bump version number to 0.2.0.0
848Ian Lynagh <igloo@earth.li>**20080920160016]
849[TAG 6.10 branch has been forked
850Ian Lynagh <igloo@earth.li>**20080919123438]
851[Fixed typo in updateMinWithKey / updateMaxWithKey
852sedillard@gmail.com**20080704054350]
853[follow library changes
854Ian Lynagh <igloo@earth.li>**20080903223610]
855[add include/Typeable.h to extra-source-files
856Ross Paterson <ross@soi.city.ac.uk>**20080831181402]
857[fix cabal build-depends for nhc98
858Malcolm.Wallace@cs.york.ac.uk**20080828104248]
859[Add a dep on syb
860Ian Lynagh <igloo@earth.li>**20080825214314]
861[add category field
862Ross Paterson <ross@soi.city.ac.uk>**20080824003013]
863[we depend on st, now split off from base
864Ian Lynagh <igloo@earth.li>**20080823223053]
865[specialize functions that fail in a Monad to Maybe (proposal #2309)
866Ross Paterson <ross@soi.city.ac.uk>**20080722154812
867 
868 Specialize functions signatures like
869 
870        lookup :: (Monad m, Ord k) => k -> Map k a -> m a
871 to
872        lookup :: (Ord k) => k -> Map k a -> Maybe a
873 
874 for simplicity and safety.  No information is lost, as each of these
875 functions had only one use of fail, which is now changed to Nothing.
876]
877[tighter description of split (addresses #2447)
878Ross Paterson <ross@soi.city.ac.uk>**20080717064838]
879[Make warning-clean with GHC again
880Ian Lynagh <igloo@earth.li>**20080623232023
881 With any luck we have now converged on a solution that works everywhere!
882]
883[Undo more Data.Typeable-related breakage for non-ghc.
884Malcolm.Wallace@cs.york.ac.uk**20080623092757]
885[Placate GHC with explicit import lists
886Ian Lynagh <igloo@earth.li>**20080620183926]
887[undo breakage caused by -Wall cleaning
888Malcolm.Wallace@cs.york.ac.uk**20080620093922
889 The import of Data.Typeable is still required, at least for non-GHC.
890]
891[Make the package -Wall clean
892Ian Lynagh <igloo@earth.li>**20080618233627]
893[List particular extensions rather than -fglasgow-exts
894Ian Lynagh <igloo@earth.li>**20080616232035]
895[Avoid using deprecated flags
896Ian Lynagh <igloo@earth.li>**20080616145241]
897[TAG 2008-05-28
898Ian Lynagh <igloo@earth.li>**20080528004309]
899Patch bundle hash:
9006d83a683a4b67a29268cb19890d3e5ec5a20795b