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

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

Considerably better documented, benchmarked, optimized, and more concise implementation of the above methods.

Line 
1Thu Jul 16 20:04:53 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**20090717000453
8 Ignore-this: 2afb31c5ec1ae0fa48bc5e191082a128
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+       iterateN,       -- :: 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+       filter,         -- :: (a -> Bool) -> Seq a -> Seq a
44+       -- ** Sorts
45+       sort,           -- :: Ord a => Seq a -> Seq a
46+       sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a
47        -- ** Indexing
48        index,          -- :: Seq a -> Int -> a
49        adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a
50hunk ./Data/Sequence.hs 85
51        splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)
52        -- * Transformations
53        reverse,        -- :: Seq a -> Seq a
54+       -- ** Zips
55+       zip,            -- :: Seq a -> Seq b -> Seq (a, b)
56+       zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
57+       zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
58+       zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
59+       zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
60+       zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
61 #if TESTING
62        valid,
63 #endif
64hunk ./Data/Sequence.hs 98
65        ) where
66 
67 import Prelude hiding (
68-       null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
69-       reverse)
70-import qualified Data.List (foldl')
71-import Control.Applicative (Applicative(..), (<$>))
72+       null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1, span,
73+       scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
74+       takeWhile, dropWhile, break, iterate, reverse, filter)
75+import qualified Data.List (foldl', zipWith)
76+import Control.Applicative (Applicative(..), (<$>), liftA, liftA2, liftA3)
77 import Control.Monad (MonadPlus(..))
78 import Data.Monoid (Monoid(..))
79 import Data.Foldable
80hunk ./Data/Sequence.hs 120
81 #endif
82 
83 #if TESTING
84-import Control.Monad (liftM, liftM3, liftM4)
85-import Test.QuickCheck
86+import Control.Monad (liftM, liftM2, liftM3, liftM4)
87+import Test.QuickCheck hiding ((><))
88 #endif
89 
90 infixr 5 `consTree`
91hunk ./Data/Sequence.hs 126
92 infixl 5 `snocTree`
93+infixr 5 `consDigitToTree`
94+infixl 6 `snocDigitToTree`
95 
96 infixr 5 ><
97 infixr 5 <|, :<
98hunk ./Data/Sequence.hs 280
99                        traverse f sf
100 
101 {-# INLINE deep #-}
102-{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
103-{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
104+{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
105+{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
106 deep           :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
107 deep pr m sf   =  Deep (size pr + size m + size sf) pr m sf
108 
109hunk ./Data/Sequence.hs 318
110        foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
111 
112 instance Functor Digit where
113-       fmap = fmapDefault
114+       fmap f (One x) = One (f x)
115+       fmap f (Two x y) = Two (f x) (f y)
116+       fmap f (Three x y z) = Three (f x) (f y) (f z)
117+       fmap f (Four x y z w) = Four (f x) (f y) (f z) (f w)
118 
119 instance Traversable Digit where
120hunk ./Data/Sequence.hs 324
121+       {-# INLINE traverse #-}
122        traverse f (One a) = One <$> f a
123        traverse f (Two a b) = Two <$> f a <*> f b
124        traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
125hunk ./Data/Sequence.hs 331
126        traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
127 
128 instance Sized a => Sized (Digit a) where
129-       {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
130-       {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
131-       size xs = foldl (\ i x -> i + size x) 0 xs
132+       size = sizeDigit
133+
134+{-# SPECIALIZE sizeDigit :: Digit (Elem a) -> Int #-}
135+{-# SPECIALIZE sizeDigit :: Digit (Node a) -> Int #-}
136+sizeDigit :: Sized a => Digit a -> Int
137+sizeDigit (One x) = size x
138+sizeDigit (Two x y) = size x + size y
139+sizeDigit (Three x y z) = size x + size y + size z
140+sizeDigit (Four x y z w) = size x + size y + size z + size w
141 
142 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
143 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
144hunk ./Data/Sequence.hs 366
145        foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
146 
147 instance Functor Node where
148-       fmap = fmapDefault
149+       fmap f (Node2 n a b) = Node2 n (f a) (f b)
150+       fmap f (Node3 n a b c) = Node3 n (f a) (f b) (f c)
151 
152 instance Traversable Node where
153        traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
154hunk ./Data/Sequence.hs 415
155        showsPrec p (Elem x) = showsPrec p x
156 #endif
157 
158+-- Applicative construction
159+
160+newtype Id a = Id {runId :: a}
161+
162+instance Functor Id where
163+       fmap f (Id x) = Id (f x)
164+
165+instance Applicative Id where
166+       pure = Id
167+       m <*> k = Id (runId m (runId k))
168+
169+newtype State s a = State {runState :: s -> (s, a)}
170+
171+instance Functor (State s) where
172+       fmap = liftA
173+
174+instance Applicative (State s) where
175+       pure x = State $ \ s -> (s, x)
176+       m <*> k = State $ \ s -> case runState m s of
177+               (s', f) -> case runState k s' of
178+                       (s'', x) -> (s'', f x)
179+
180+execState :: State s a -> s -> a
181+execState m x = snd (runState m x)
182+
183+-- | 'applicativeTree' takes an Applicative-wrapped construction of a piece of a FingerTree, assumed
184+-- to always have the same size (which is put in the second argument), and replicates it as many times
185+-- as specified.  This encapsulates the behavior of several procedures, most notably iterate and replicate.
186+
187+{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
188+{-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-}
189+       -- Special note: the Id specialization automatically does node sharing, reducing memory usage of the
190+       -- resulting tree to /O(log n)/.
191+applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
192+applicativeTree n mSize m = mSize `seq` case n of
193+       0       -> pure Empty
194+       1       -> liftA Single m
195+       2       -> deepA one empty one
196+       3       -> deepA two empty one
197+       4       -> deepA two empty two
198+       5       -> deepA three empty two
199+       6       -> deepA three empty three
200+       7       -> deepA four empty three
201+       8       -> deepA four empty four
202+       _       -> let (q, r) = n `quotRem` 3 in q `seq` case r of
203+               0       -> deepA three (applicativeTree (q - 2) mSize' n3) three
204+               1       -> deepA four (applicativeTree (q - 2) mSize' n3) three
205+               _       -> deepA four (applicativeTree (q - 2) mSize' n3) four
206+       where   one = liftA One m
207+               two = liftA2 Two m m
208+               three = liftA3 Three m m m
209+               four = liftA3 Four m m m <*> m
210+               deepA = liftA3 (Deep (n * mSize))
211+               mSize' = 3 * mSize
212+               n3 = liftA3 (Node3 mSize') m m m
213+               empty = pure Empty
214+
215 ------------------------------------------------------------------------
216 -- Construction
217 ------------------------------------------------------------------------
218hunk ./Data/Sequence.hs 484
219 singleton      :: a -> Seq a
220 singleton x    =  Seq (Single (Elem x))
221 
222+-- | /O(log n)/. @replicate n x@ is a sequence of length @n@ with @x@ the value of every element.
223+replicate      :: Int -> a -> Seq a
224+replicate n x  = Seq (runId (applicativeTree n 1 (Id (Elem x))))
225+
226 -- | /O(1)/. Add an element to the left end of a sequence.
227 -- Mnemonic: a triangle with the single element at the pointy end.
228 (<|)           :: a -> Seq a -> Seq a
229hunk ./Data/Sequence.hs 584
230 appendTree1 xs a Empty =
231        xs `snocTree` a
232 appendTree1 (Single x) a xs =
233-       x `consTree` a `consTree` xs
234+       Two x a `consDigitToTree` xs
235 appendTree1 xs a (Single x) =
236hunk ./Data/Sequence.hs 586
237-       xs `snocTree` a `snocTree` x
238+       xs `snocDigitToTree` Two a x
239 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
240        Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
241 
242hunk ./Data/Sequence.hs 626
243 
244 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
245 appendTree2 Empty a b xs =
246-       a `consTree` b `consTree` xs
247+       Two a b `consDigitToTree` xs
248 appendTree2 xs a b Empty =
249hunk ./Data/Sequence.hs 628
250-       xs `snocTree` a `snocTree` b
251+       xs `snocDigitToTree` Two a b
252 appendTree2 (Single x) a b xs =
253hunk ./Data/Sequence.hs 630
254-       x `consTree` a `consTree` b `consTree` xs
255+       Three x a b `consDigitToTree` xs
256 appendTree2 xs a b (Single x) =
257hunk ./Data/Sequence.hs 632
258-       xs `snocTree` a `snocTree` b `snocTree` x
259+       xs `snocDigitToTree` Three a b x
260 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
261        Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
262 
263hunk ./Data/Sequence.hs 672
264 
265 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
266 appendTree3 Empty a b c xs =
267-       a `consTree` b `consTree` c `consTree` xs
268+       Three a b c `consDigitToTree` xs
269 appendTree3 xs a b c Empty =
270hunk ./Data/Sequence.hs 674
271-       xs `snocTree` a `snocTree` b `snocTree` c
272+       xs `snocDigitToTree` Three a b c
273 appendTree3 (Single x) a b c xs =
274hunk ./Data/Sequence.hs 676
275-       x `consTree` a `consTree` b `consTree` c `consTree` xs
276+       Four x a b c `consDigitToTree` xs
277 appendTree3 xs a b c (Single x) =
278hunk ./Data/Sequence.hs 678
279-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
280+       xs `snocDigitToTree` Four a b c x
281 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
282        Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
283 
284hunk ./Data/Sequence.hs 718
285 
286 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
287 appendTree4 Empty a b c d xs =
288-       a `consTree` b `consTree` c `consTree` d `consTree` xs
289+       Four a b c d `consDigitToTree` xs
290 appendTree4 xs a b c d Empty =
291hunk ./Data/Sequence.hs 720
292-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
293+       xs `snocDigitToTree` Four a b c d
294 appendTree4 (Single x) a b c d xs =
295hunk ./Data/Sequence.hs 722
296-       x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
297+       x `consTree` Four a b c d `consDigitToTree` xs
298 appendTree4 xs a b c d (Single x) =
299hunk ./Data/Sequence.hs 724
300-       xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
301+       xs `snocDigitToTree` Four a b c d `snocTree` x
302 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
303        Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
304 
305hunk ./Data/Sequence.hs 762
306 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
307        appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
308 
309+-- Cons and snoc for entire digits at once.  This code was automatically generated.
310+--
311+-- For general internal use, this is *considerably more efficient* than repeated use of
312+-- consTree or snocTree, which end up case'ing the appropriate digit once for every
313+-- insertion, while this code only does it once.
314+
315+{-# SPECIALIZE consDigitToTree :: Digit (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
316+{-# SPECIALIZE consDigitToTree :: Digit (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-}
317+consDigitToTree :: Sized a => Digit a -> FingerTree a -> FingerTree a
318+consDigitToTree dig Empty
319+       = digitToTree dig
320+consDigitToTree dig (Single a)
321+       = Deep (size dig + size a) dig Empty (One a)
322+consDigitToTree dig@(One a) (Deep n (One x) m sf)
323+       = Deep (n + size dig) (Two a x) m sf
324+consDigitToTree dig@(One a) (Deep n (Two x y) m sf)
325+       = Deep (n + size dig) (Three a x y) m sf
326+consDigitToTree dig@(One a) (Deep n (Three x y z) m sf)
327+       = Deep (n + size dig) (Four a x y z) m sf
328+consDigitToTree dig@(One a) (Deep n (Four x y z w) m sf)
329+       = Deep (n + size dig) (Two a x) ((node3 y z w) `consTree` m) sf
330+consDigitToTree dig@(Two a b) (Deep n (One x) m sf)
331+       = Deep (n + size dig) (Three a b x) m sf
332+consDigitToTree dig@(Two a b) (Deep n (Two x y) m sf)
333+       = Deep (n + size dig) (Four a b x y) m sf
334+consDigitToTree dig@(Two a b) (Deep n (Three x y z) m sf)
335+       = Deep (n + size dig) (Two a b) ((node3 x y z) `consTree` m) sf
336+consDigitToTree dig@(Two a b) (Deep n (Four x y z w) m sf)
337+       = Deep (n + size dig) (Three a b x) ((node3 y z w) `consTree` m) sf
338+consDigitToTree dig@(Three a b c) (Deep n (One x) m sf)
339+       = Deep (n + size dig) (Four a b c x) m sf
340+consDigitToTree dig@(Three a b c) (Deep n (Two x y) m sf)
341+       = Deep (n + size dig) (Two a b) ((node3 c x y) `consTree` m) sf
342+consDigitToTree dig@(Three a b c) (Deep n (Three x y z) m sf)
343+       = Deep (n + size dig) (Three a b c) ((node3 x y z) `consTree` m) sf
344+consDigitToTree dig@(Three a b c) (Deep n (Four x y z w) m sf)
345+       = Deep (n + size dig) (One a) (Two (node3 b c x) (node3 y z w) `consDigitToTree` m) sf
346+consDigitToTree dig@(Four a b c d) (Deep n (One x) m sf)
347+       = Deep (n + size dig) (Two a b) ((node3 c d x) `consTree` m) sf
348+consDigitToTree dig@(Four a b c d) (Deep n (Two x y) m sf)
349+       = Deep (n + size dig) (Three a b c) ((node3 d x y) `consTree` m) sf
350+consDigitToTree dig@(Four a b c d) (Deep n (Three x y z) m sf)
351+       = Deep (n + size dig) (One a) (Two (node3 b c d) (node3 x y z) `consDigitToTree` m) sf
352+consDigitToTree dig@(Four a b c d) (Deep n (Four x y z w) m sf)
353+       = Deep (n + size dig) (Two a b) (Two (node3 c d x) (node3 y z w) `consDigitToTree` m) sf
354+
355+{-# SPECIALIZE snocDigitToTree :: FingerTree (Elem a) -> Digit (Elem a) -> FingerTree (Elem a) #-}
356+{-# SPECIALIZE snocDigitToTree :: FingerTree (Node a) -> Digit (Node a) -> FingerTree (Node a) #-}
357+snocDigitToTree :: Sized a => FingerTree a -> Digit a -> FingerTree a
358+snocDigitToTree Empty dig
359+       = digitToTree dig
360+snocDigitToTree (Single a) dig
361+       = Deep (size a + size dig) (One a) Empty dig
362+snocDigitToTree (Deep n pr m (One a)) dig@(One x)
363+       = Deep (n + size dig) pr m (Two a x)
364+snocDigitToTree (Deep n pr m (One a)) dig@(Two x y)
365+       = Deep (n + size dig) pr m (Three a x y)
366+snocDigitToTree (Deep n pr m (One a)) dig@(Three x y z)
367+       = Deep (n + size dig) pr m (Four a x y z)
368+snocDigitToTree (Deep n pr m (One a)) dig@(Four x y z w)
369+       = Deep (n + size dig) pr (m `snocTree` (node3 a x y)) (Two z w)
370+snocDigitToTree (Deep n pr m (Two a b)) dig@(One x)
371+       = Deep (n + size dig) pr m (Three a b x)
372+snocDigitToTree (Deep n pr m (Two a b)) dig@(Two x y)
373+       = Deep (n + size dig) pr m (Four a b x y)
374+snocDigitToTree (Deep n pr m (Two a b)) dig@(Three x y z)
375+       = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Two y z)
376+snocDigitToTree (Deep n pr m (Two a b)) dig@(Four x y z w)
377+       = Deep (n + size dig) pr (m `snocTree` (node3 a b x)) (Three y z w)
378+snocDigitToTree (Deep n pr m (Three a b c)) dig@(One x)
379+       = Deep (n + size dig) pr m (Four a b c x)
380+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Two x y)
381+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two x y)
382+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Three x y z)
383+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three x y z)
384+snocDigitToTree (Deep n pr m (Three a b c)) dig@(Four x y z w)
385+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 x y z)) (One w)
386+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(One x)
387+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Two d x)
388+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Two x y)
389+       = Deep (n + size dig) pr (m `snocTree` (node3 a b c)) (Three d x y)
390+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Three x y z)
391+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (One z)
392+snocDigitToTree (Deep n pr m (Four a b c d)) dig@(Four x y z w)
393+       = Deep (n + size dig) pr (m `snocDigitToTree` Two (node3 a b c) (node3 d x y)) (Two z w)
394+
395+-- | 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./
396+unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
397+unfoldr f b = unfoldr' empty b where
398+       -- uses tail recursion rather than, for instance, the List implementation.
399+       unfoldr' as b = case f b of
400+               Nothing         -> as
401+               Just (a, b')    -> unfoldr' (as |> a) b'
402+
403+-- | /O(n)/.  Constructs a sequence by repeated application of a function to a seed value.
404+--
405+-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
406+iterateN :: Int -> (a -> a) -> a -> Seq a
407+-- borrows the structure of the sequence from replicate and preserves it with mapAccumL
408+iterateN n f x = n `seq` Seq (execState (applicativeTree n 1 run) x)
409+       where   run = State $ \ x -> (f x, Elem x)
410+
411+
412 ------------------------------------------------------------------------
413 -- Deconstruction
414 ------------------------------------------------------------------------
415hunk ./Data/Sequence.hs 999
416 viewRTree (Deep s pr m (Four w x y z)) =
417        Just2 (Deep (s - size z) pr m (Three w x y)) z
418 
419+------------------------------------------------------------------------
420+-- Scans
421+--
422+-- These are not particularly complex applications of the Traversable
423+-- functor, though making the correspondence with Data.List exact
424+-- requires the use of (<|) and (|>).
425+--
426+-- Note that save for the single (<|) or (|>), we maintain the original
427+-- structure of the Seq, not having to do any restructuring of our own.
428+--
429+-- wasserman.louis@gmail.com, 5/23/09
430+------------------------------------------------------------------------
431+
432+-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced values from the left:
433+--
434+-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
435+scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
436+scanl f z0 xs = z0 <| snd (mapAccumL accum z0 xs)
437+       where accum x z = let x' = f x z in (x', x')
438+
439+-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
440+--
441+-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
442+scanl1 :: (a -> a -> a) -> Seq a -> Seq a
443+scanl1 f xs = case viewl xs of
444+       EmptyL          -> error "scanl1 takes a nonempty sequence as an argument"
445+       x :< xs'        -> scanl f x xs'
446+
447+-- | 'scanr' is the right-to-left dual of 'scanl'.
448+scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
449+scanr f z0 xs = snd (mapAccumR accum z0 xs) |> z0
450+       where accum z x = let z' = f x z in (z', z')
451+
452+-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
453+scanr1 :: (a -> a -> a) -> Seq a -> Seq a
454+scanr1 f xs = case viewr xs of
455+       EmptyR          -> error "scanr1 takes a nonempty sequence as an argument"
456+       xs' :> x        -> scanr f x xs'
457+
458 -- Indexing
459 
460 -- | /O(log(min(i,n-i)))/. The element at the specified position,
461hunk ./Data/Sequence.hs 1188
462 splitAt i (Seq xs)     =  (Seq l, Seq r)
463   where        (l, r)          =  split i xs
464 
465+-- | /O(n)/.  Returns a sequence of all suffixes of this sequence, longest first.  For example,
466+--
467+-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
468+--
469+-- Evaluating the /i/th tail takes /O(log(min(i, n-i)))/, but evaluating every tail in the sequence
470+-- takes /O(n)/ due to sharing.
471+tails                  :: Seq a -> Seq (Seq a)
472+tails (Seq xs)         = Seq (tailsTree (Elem . Seq) xs) |> empty
473+{-
474+tails xs = iterateN (length xs + 1) tail' xs where
475+       tail' ys _ = case viewl ys of
476+               _ :< ys'        -> ys'
477+               _               -> error "Invariant failure in Data.Sequence.tails" -- should never happen
478+-}
479+
480+-- | /O(n)/.  Returns a sequence of all prefixes of this sequence, shortest first. For example,
481+--
482+-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
483+--
484+-- Evaluating the /i/th init takes /O(log(min(i, n-i)))/, but evaluating every init in the sequence
485+-- takes /O(n)/ due to sharing. 
486+inits                  :: Seq a -> Seq (Seq a)
487+inits (Seq xs)                 = empty <| Seq (initsTree (Elem . Seq) xs)
488+-- inits = scanl (|>) empty
489+
490+-- This implementation of tails (and, analogously, inits) has the following algorithmic advantages:
491+--     Evaluating each tail in the sequence takes linear total time, which is better than we could say for
492+--             @fromList [drop n xs | n <- [0..length xs]]@.
493+--     Evaluating any individual tail takes logarithmic time, which is better than we can say for either
494+--             @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
495+--
496+-- Moreover, if we actually look at every tail in the sequence, the following benchmarks demonstrate that
497+-- this implementation is actually slightly faster than any of the above:
498+--
499+-- Times (ms)    min    mean    +/-sd  median    max
500+-- Seq.tails:  16.875  20.405   4.247  19.663  47.972
501+-- scanr:      68.429  76.948   6.505  75.264  99.650
502+-- iterateN:   17.571  22.231   1.031  22.251  23.917
503+--
504+-- The algorithm for tails (and, analogously, inits) is as follows:
505+--
506+-- A Node in the FingerTree of tails is constructed by evaluating the corresponding tail of the FingerTree
507+-- of Nodes, considering the first Node in this tail, and constructing a Node in which each tail of this
508+-- Node is made to be the prefix of the remaining tree.  This ends up working quite elegantly, as the remainder of
509+-- the tail of the FingerTree of Nodes becomes the middle of a new tail, the suffix of the Node is the
510+-- prefix, and the suffix of the original tree is retained.
511+--
512+-- In particular, evaluating the /i/th tail involves making as many partial evaluations as the Node depth of
513+-- the /i/th element.  In addition, when we evaluate the /i/th tail, and we also evaluate the /j/th tail,
514+-- and /m/ Nodes are on the path to both /i/ and /j/, each of those /m/ evaluations are shared between
515+-- the computation of the /i/th and /j/th tails.
516+--
517+-- wasserman.louis@gmail.com, 7/16/09
518+
519+-- | Given the size of a digit and the digit itself, efficiently converts it to a FingerTree.
520+digitToTree' :: Int -> Digit a -> FingerTree a
521+digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
522+digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
523+digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
524+digitToTree' n (One a) = n `seq` Single a
525+
526+{-# INLINE scanlSize #-}
527+scanlSize :: (Traversable f, Sized a) => (b -> Int -> b) -> b -> f a -> f b
528+scanlSize f z d = snd (mapAccumL (\ acc x -> let ans = f acc (size x) in (ans, ans)) z d)
529+
530+{-# INLINE scanrSize #-}
531+scanrSize :: (Traversable f, Sized a) => (Int -> b -> b) -> b -> f a -> f b
532+scanrSize f z d = snd (mapAccumR (\ acc x -> let ans = size x `f` acc in (ans, ans)) z d)
533+
534+{-# INLINE tailPr #-}
535+-- | Given a Deep FingerTree, constructs the prefix of its tree of tails.
536+tailPr :: Sized a => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a)
537+tailPr n pr m sf = n `seq` let t = Deep n pr m sf in case (pr, scanlSize (-) n pr) of
538+       (One _, _)      -> One t
539+       (Two a b, Two sza _)
540+                       -> sza `seq` Two t (Deep sza (One b) m sf)
541+       (Three a b c, Three sza szb _)
542+                       -> szb `seq` Three t (Deep sza (Two b c) m sf) (Deep szb (One c) m sf)
543+       (Four a b c d, Four sza szb szc _)
544+                       -> szc `seq` Four t (Deep sza (Three b c d) m sf) (Deep szb (Two c d) m sf)
545+                               (Deep szc (One d) m sf)
546+
547+{-# INLINE initPr #-}
548+-- | Constructs the inits of the specified digits.
549+initPr :: Sized a => Digit a -> Digit (FingerTree a)
550+initPr pr = case (pr, scanlSize (+) 0 pr) of
551+       (One a, _)      -> One (Single a)
552+       (Two a b, Two _ szb)
553+                       -> szb `seq` Two (Single a) (digitToTree' szb (Two a b))
554+       (Three a b c, Three _ szb szc)
555+                       -> szc `seq` Three (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c))
556+       (Four a b c d, Four _ szb szc szd)
557+                       -> szd `seq` Four (Single a) (digitToTree' szb (Two a b)) (digitToTree' szc (Three a b c))
558+                               (digitToTree' szd (Four a b c d))
559+
560+{-# INLINE tailSf #-}
561+-- | Constructs the tails of the specified digit.
562+tailSf :: Sized a => Digit a -> Digit (FingerTree a)
563+tailSf sf = case (sf, scanrSize (+) 0 sf) of
564+       (One a, _)      -> One (Single a)
565+       (Two a b, Two sza _)
566+                       -> sza `seq` Two (digitToTree' sza (Two a b)) (Single b)
567+       (Three a b c, Three sza szb _)
568+                       -> sza `seq` Three (digitToTree' sza (Three a b c)) (digitToTree' szb (Two b c))
569+                               (Single c)
570+       (Four a b c d, Four sza szb szc _)
571+                       -> sza `seq` Four (digitToTree' sza (Four a b c d)) (digitToTree' szb (Three b c d))
572+                               (digitToTree' szc (Two c d)) (Single d)
573+
574+{-# INLINE initSf #-}
575+-- | Constructs the suffix of the tree of inits of the specified Deep tree.
576+initSf :: (Sized a) => Int -> Digit a -> FingerTree (Node a) -> Digit a -> Digit (FingerTree a)
577+initSf n pr m sf = n `seq` let t = Deep n pr m sf in case (sf, (scanrSize subtract n sf)) of
578+       (One _, _)      -> One t
579+       (Two a b, Two sza _)
580+                       -> sza `seq` Two (Deep sza pr m (One a)) t
581+       (Three a b c, Three sza szb _)
582+                       -> sza `seq` Three (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) t
583+       (Four a b c d, Four sza szb szc _)
584+                       -> sza `seq` Four (Deep sza pr m (One a)) (Deep szb pr m (Two a b)) (Deep szc pr m (Three a b c)) t
585+
586+{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
587+{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
588+-- | Given a function to apply to tails of a tree, applies that function to every tail of the specified tree.
589+tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
590+tailsTree _ Empty = Empty
591+tailsTree f (Single x) = Single (f (Single x))
592+tailsTree f (Deep n pr m sf) = sfSize `seq`
593+       Deep n (fmap f (tailPr n pr m sf)) (tailsTree f' m) (fmap f (tailSf sf))
594+       where   sfSize = size sf
595+               f' ms = case viewLTree ms of
596+                       Nothing2 -> error "tailsTree should not encounter empty tails"
597+                       Just2 (Node2 n' a b) m' -> let sz2 = sz + size a; sz = size b + size m' + sfSize in
598+                               sz2 `seq` Node2 n' (f (Deep sz2 (Two a b) m' sf))
599+                                       (f (Deep sz (One b) m' sf))
600+                       Just2 (Node3 n' a b c) m' ->
601+                               let     sz = size c + size m' + sfSize
602+                                       sz2 = size b + sz
603+                                       sz3 = size a + sz2
604+                                in sz3 `seq` Node3 n' (f (Deep sz3 (Three a b c) m' sf))
605+                                               (f (Deep sz2 (Two b c) m' sf))
606+                                               (f (Deep sz (One c) m' sf))
607+
608+{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
609+{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
610+-- | Given a function to apply to inits of a tree, applies that function to every init of the specified tree.
611+initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
612+initsTree _ Empty = Empty
613+initsTree f (Single x) = Single (f (Single x))
614+initsTree f (Deep n pr m sf) = prSize `seq`
615+       Deep n (fmap f (initPr pr)) (initsTree f' m) (fmap f (initSf n pr m sf))
616+       where   prSize = size pr
617+               f' ms = case viewRTree ms of
618+                       Nothing2 -> error "initsTree should not encounter empty inits"
619+                       Just2 m' (Node2 n' a b) -> let sza = prSize + size m' + size a; szb = sza + size b in szb `seq`
620+                               Node2 n' (f (Deep sza pr m' (One a)))
621+                                       (f (Deep szb pr m' (Two a b)))
622+                       Just2 m' (Node3 n' a b c) -> let        sza = prSize + size m' + size a
623+                                                               szb = sza + size b
624+                                                               szc = szb + size c in
625+                               szc `seq` Node3 n' (f (Deep sza pr m' (One a)))
626+                                               (f (Deep szb pr m' (Two a b)))
627+                                               (f (Deep szc pr m' (Three a b c)))
628+
629 split :: Int -> FingerTree (Elem a) ->
630        (FingerTree (Elem a), FingerTree (Elem a))
631 split i Empty  = i `seq` (Empty, Empty)
632hunk ./Data/Sequence.hs 1375
633                        Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
634   | i < spm    = case splitTree im m of
635                        Split ml xs mr -> case splitNode (im - size ml) xs of
636-                           Split l x r -> Split (deepR pr  ml l) x (deepL r mr sf)
637+                           Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
638   | otherwise  = case splitDigit (i - spm) sf of
639hunk ./Data/Sequence.hs 1377
640-                       Split l x r -> Split (deepR pr  m  l) x (maybe Empty digitToTree r)
641+                       Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
642   where        spr     = size pr
643        spm     = spr + size m
644        im      = i - spr
645hunk ./Data/Sequence.hs 1382
646 
647+{-# SPECIALIZE pullL :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Elem a) #-}
648+{-# SPECIALIZE pullL :: Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node a) #-}
649+pullL :: Sized a => Digit a -> FingerTree (Node a) -> FingerTree a
650+pullL pr m = case viewRTree m of
651+       Nothing2        -> digitToTree pr
652+       Just2 m' sf     -> Deep (size pr + size m) pr m' (nodeToDigit sf)
653+
654+{-# SPECIALIZE pullR :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
655+{-# SPECIALIZE pullR :: FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
656+pullR :: Sized a => FingerTree (Node a) -> Digit a -> FingerTree a
657+pullR m sf = case viewLTree m of
658+       Nothing2        -> digitToTree sf
659+       Just2 pr m'     -> Deep (size sf + size m) (nodeToDigit pr) m' sf
660+
661 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
662 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
663 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
664hunk ./Data/Sequence.hs 1399
665-deepL Nothing m sf     = case viewLTree m of
666-       Nothing2        -> digitToTree sf
667-       Just2 a m'      -> Deep (size m + size sf) (nodeToDigit a) m' sf
668+deepL Nothing m sf     = pullR m sf
669 deepL (Just pr) m sf   = deep pr m sf
670 
671 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
672hunk ./Data/Sequence.hs 1405
673 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
674 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
675-deepR pr m Nothing     = case viewRTree m of
676-       Nothing2        -> digitToTree pr
677-       Just2 m' a      -> Deep (size pr + size m) pr m' (nodeToDigit a)
678+deepR pr m Nothing     = pullL pr m
679 deepR pr m (Just sf)   = deep pr m sf
680 
681 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
682hunk ./Data/Sequence.hs 1445
683        sab     = sa + size b
684        sabc    = sab + size c
685 
686+-- | /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@.
687+takeWhile :: (a -> Bool) -> Seq a -> Seq a
688+takeWhile p xs = fst (span p xs)
689+
690+-- | /O(i)/ where /i/ is the breakpoint index.  @'dropWhile' p xs@ returns the suffix remaining after @takeWhile p xs@.
691+dropWhile :: (a -> Bool) -> Seq a -> Seq a
692+dropWhile p xs = snd (span p xs)
693+
694+-- | /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.
695+span :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
696+-- This doesn't make any more of a traversal than is necessary, exploiting the laziness of foldr and the structure preservation of mapAccumL.
697+span p xs = splitAt ix xs
698+       where   indexed = snd (mapAccumL (\ i x -> i `seq` (i + 1, (x, i))) 0 xs)
699+               ix = foldr (\ (x, i) i' -> if p x then i' else i) (length xs) indexed
700+
701+-- | /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.
702+break :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
703+break p xs = span (not . p) xs
704+
705+-- | /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.
706+partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
707+partition p = foldl' partition' (empty, empty) where
708+       partition' (xs, ys) x
709+               | p x           = (xs |> x, ys)
710+               | otherwise     = (xs, ys |> x)
711+
712+-- | /O(n)/.  The 'filter' function takes a predicate @p@ and a sequence @xs@ and returns a sequence of those elements which satisfy the predicate.
713+filter :: (a -> Bool) -> Seq a -> Seq a
714+filter p = foldl' filter' empty where
715+       filter' ys x
716+               | p x           = ys |> x
717+               | otherwise     = ys
718+
719 ------------------------------------------------------------------------
720 -- Lists
721 ------------------------------------------------------------------------
722hunk ./Data/Sequence.hs 1504
723                (reverseTree (reverseNode f) m)
724                (reverseDigit f pr)
725 
726+{-# INLINE reverseDigit #-}
727 reverseDigit :: (a -> a) -> Digit a -> Digit a
728 reverseDigit f (One a) = One (f a)
729 reverseDigit f (Two a b) = Two (f b) (f a)
730hunk ./Data/Sequence.hs 1515
731 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
732 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
733 
734+------------------------------------------------------------------------
735+-- Zipping
736+--
737+-- We implement zipping on sequences by zipping left and right digits simultaneously and
738+-- processing excess appropriately.  This allows several elements to be ``zipped''
739+-- in a single go, which is significantly faster than it might be for a linked-list approach,
740+-- where we'd have to do at least one dereference for each element.
741+------------------------------------------------------------------------
742+
743+-- | /O(n)/.  'zip' takes two sequences and returns a sequence of corresponding pairs. 
744+-- If one input is short, excess elements of the longer sequence are discarded.
745+zip :: Seq a -> Seq b -> Seq (a, b)
746+zip = zipWith (,)
747+
748+-- | /O(n)/.  'zipWith' generalizes 'zip' by zipping with the function given as the first argument,
749+-- instead of a tupling function.  For example, @zipWith (+)@ is applied to two sequences to take
750+-- the sequence of corresponding sums.
751+zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
752+zipWith f xs ys
753+       | length xs <= length ys        = zipWith' f xs ys
754+       | otherwise                     = zipWith' (flip f) ys xs
755+       where  zipWith' f xs ys =
756+               let zipper ys x = case viewl ys of
757+                       EmptyL  -> error "zipper should never encounter an empty second string"
758+                       y :< ys -> (ys, f x y)
759+                       in snd (mapAccumL zipper ys xs)
760+
761+zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
762+zip3 = zipWith3 (,,)
763+
764+zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
765+zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3
766+
767+zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
768+zip4 = zipWith4 (,,,)
769+
770+zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
771+zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4
772+
773+------------------------------------------------------------------------
774+-- Sorting
775+--
776+-- This is an unstable heap sort implementation based on pairing heaps.  Because the internal structure of
777+-- sequences is quite varied, it is difficult to get blocks of elements of roughly the same length, which
778+-- would improve merge sort performance.  Pairing heaps, on the other hand, are relatively resistant to the
779+-- effects of merging heaps of wildly different sizes, as guaranteed by its amortized constant-time merge
780+-- operation.  Moreover, extensive use of SpecConstr transformations can be done on pairing heaps,
781+-- especially when we're only constructing them to immediately be unrolled.
782+--
783+-- On purely random sequences, I get the following statistics:
784+--
785+-- Times (ms)       min    mean    +/-sd  median    max
786+-- to/from list:  52.506  54.734   1.097  54.487  59.053
787+-- pairing heap:  29.966  30.402   0.753  30.253  35.372
788+--
789+-- In addition, on strictly increasing sequences, I get the following measurements:
790+--
791+-- Times (ms)       min    mean    +/-sd  median    max
792+-- to/from list:  31.788  33.924   1.431  33.835  41.310
793+-- pairing heap:   8.578   9.029   0.289   8.956  10.066
794+--
795+-- These measurements are with no RTS options.  With +RTS -H128m, on pure random sequences of length 50000,
796+-- the margin is considerably thinner, but still in place. 
797+--
798+-- Times (ms)       min    mean    +/-sd  median    max
799+-- to/from list:  28.262  43.814   5.922  43.127  55.574
800+-- pairing heap:  23.953  38.682   4.811  39.536  51.857
801+
802+--
803+-- In exchange for such a significant increase in performance, forcing users to convert  to and
804+-- from lists to get a stable sort seems acceptable.  (The idiom is (fromList . Data.List.sort . toList),
805+-- which is sufficiently short not to be a major issue.)
806+--
807+-- wasserman.louis@gmail.com, 7/16/09
808+------------------------------------------------------------------------
809+
810+-- | /O(n log n)/.  'sort' sorts the specified 'Seq' by the natural ordering of its elements.  The sort is not stable. 
811+-- The fastest way to stably sort a 'Seq' is to convert it to a list, use 'Data.List.sort', and convert it back to a 'Seq'.
812+sort :: Ord a => Seq a -> Seq a
813+sort = sortBy compare
814+
815+-- | /O(n log n)/.  A generalization of 'sort', 'sortBy' takes an arbitrary comparator and sorts the specified sequence.  The sort is not stable.
816+-- The fastest way to stably sort a 'Seq' is to convert it to a list, use 'Data.List.sortBy', and convert it back to a 'Seq'.
817+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
818+       -- Todo: examine whether or not stable sorting could be brute-forced by adding an index tag to PQueues.
819+sortBy cmp (Seq xs) = fromList2 (size xs) $ maybe [] (unrollPQ cmp) $ toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
820+       --fromList . Data.List.sortBy cmp . toList
821+
822+fromList2 :: Int -> [a] -> Seq a
823+-- fromList2, given a list and its length, constructs a completely balanced Seq whose elements are that list
824+-- using the applicativeTree generalization.
825+fromList2 n xs = Seq (execState (applicativeTree n 1 (State run)) xs) where
826+       run (x:xs) = (xs, Elem x)
827+
828+-- | A 'PQueue' is a simple pairing heap.
829+data PQueue e = PQueue e (PQL e)
830+
831+data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
832+       -- admittedly a glorified list of PQueues, but nevertheless encourages SpecConstr use
833+
834+infixr 8 :&
835+
836+#if TESTING
837+
838+instance Functor PQueue where
839+       fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
840+
841+instance Functor PQL where
842+       fmap f (q :& qs) = fmap f q :& fmap f qs
843+       fmap f Nil = Nil
844+
845+instance Show e => Show (PQueue e) where
846+       show = unlines . draw . fmap show
847+
848+-- borrowed wholesale from Data.Tree, as Data.Tree actually depends on Data.Sequence
849+draw :: PQueue String -> [String]
850+draw (PQueue x ts0) = x : drawSubTrees ts0
851+  where drawSubTrees Nil = []
852+       drawSubTrees (t :& Nil) =
853+               "|" : shift "`- " "   " (draw t)
854+       drawSubTrees (t :& ts) =
855+               "|" : shift "+- " "|  " (draw t) ++ drawSubTrees ts
856+
857+       shift first other = Data.List.zipWith (++) (first : repeat other)
858+#endif
859+
860+-- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into a sorted list.
861+unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
862+unrollPQ cmp = unrollPQ' where
863+       {-# INLINE unrollPQ' #-}
864+       unrollPQ' (PQueue x ts) = x:mergePQs0 ts
865+       (<>) = mergePQ cmp
866+       mergePQs0 Nil = []
867+       mergePQs0 (t :& Nil) = unrollPQ' t
868+       mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
869+       mergePQs t ts = t `seq` case ts of
870+               Nil             -> unrollPQ' t
871+               t1 :& Nil       -> unrollPQ' (t <> t1)
872+               t1 :& t2 :& ts  -> mergePQs (t <> (t1 <> t2)) ts
873+
874+-- | 'toPQ', given an ordering function and a mechanism for queueifying elements, converts a 'FingerTree' to a 'PQueue'.
875+toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
876+toPQ cmp f (Deep _ pr m sf) = Just $ case toPQ cmp fNode m of
877+       Nothing -> fDig pr <> fDig sf
878+       Just m' -> fDig pr <> m' <> fDig sf
879+ where fNode (Node2 _ a b) = f a <> f b
880+       fNode (Node3 _ a b c) = f a <> f b <> f c
881+       (<>) = mergePQ cmp
882+       fDig (One a) = f a
883+       fDig (Two a b) = f a <> f b
884+       fDig (Three a b c) = f a <> f b <> f c
885+       fDig (Four a b c d) = (f a <> f b) <> (f c <> f d)
886+toPQ _ f (Single x) = Just (f x)
887+toPQ _ _ Empty = Nothing
888+
889+-- | 'mergePQ' merges two 'PQueue's.
890+mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
891+mergePQ cmp (PQueue x1 ts1) (PQueue x2 ts2)
892+       | cmp x1 x2 == GT       = PQueue x2 (PQueue x1 ts1 :& ts2)
893+       | otherwise             = PQueue x1 (PQueue x2 ts2 :& ts1)
894+
895 #if TESTING
896 
897 ------------------------------------------------------------------------
898hunk ./Data/Sequence.hs 1684
899 
900 instance Arbitrary a => Arbitrary (Seq a) where
901        arbitrary = liftM Seq arbitrary
902-       coarbitrary (Seq x) = coarbitrary x
903+       shrink (Seq x) = map Seq (shrink x)
904 
905 instance Arbitrary a => Arbitrary (Elem a) where
906        arbitrary = liftM Elem arbitrary
907hunk ./Data/Sequence.hs 1688
908-       coarbitrary (Elem x) = coarbitrary x
909+       shrink _ = []
910 
911 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
912        arbitrary = sized arb
913hunk ./Data/Sequence.hs 1697
914                arb 1 = liftM Single arbitrary
915                arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
916 
917-       coarbitrary Empty = variant 0
918-       coarbitrary (Single x) = variant 1 . coarbitrary x
919-       coarbitrary (Deep _ pr m sf) =
920-               variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf
921+       shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]
922+       shrink (Deep _ pr m sf) = [deep pr' m sf | pr' <- shrink pr] ++ [deep pr m' sf | m' <- shrink m] ++ [deep pr m sf' | sf' <- shrink sf]
923+       shrink (Single _) = [Empty]
924+       shrink Empty = []
925 
926 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
927        arbitrary = oneof [
928hunk ./Data/Sequence.hs 1707
929                        liftM2 node2 arbitrary arbitrary,
930                        liftM3 node3 arbitrary arbitrary arbitrary]
931 
932-       coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b
933-       coarbitrary (Node3 _ a b c) =
934-               variant 1 . coarbitrary a . coarbitrary b . coarbitrary c
935+       shrink (Node2 _ a b) = [node2 a' b | a' <- shrink a] ++ [node2 a b' | b' <- shrink b]
936+       shrink (Node3 _ a b c) = [node2 a b, node2 a c, node2 b c] ++
937+               [node3 a' b c | a' <- shrink a] ++ [node3 a b' c | b' <- shrink b] ++ [node3 a b c' | c' <- shrink c]
938 
939 instance Arbitrary a => Arbitrary (Digit a) where
940        arbitrary = oneof [
941hunk ./Data/Sequence.hs 1717
942                        liftM2 Two arbitrary arbitrary,
943                        liftM3 Three arbitrary arbitrary arbitrary,
944                        liftM4 Four arbitrary arbitrary arbitrary arbitrary]
945-
946-       coarbitrary (One a) = variant 0 . coarbitrary a
947-       coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b
948-       coarbitrary (Three a b c) =
949-               variant 2 . coarbitrary a . coarbitrary b . coarbitrary c
950-       coarbitrary (Four a b c d) =
951-               variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
952+       
953+       shrink (One a) = map One (shrink a)
954+       shrink (Two a b) = [One a, One b]
955+       shrink (Three a b c) = [Two a b, Two a c, Two b c]
956+       shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
957 
958 ------------------------------------------------------------------------
959 -- Valid trees
960hunk ./containers.cabal 23
961     location: http://darcs.haskell.org/packages/containers/
962 
963 Library {
964-    build-depends: base, array
965+    build-depends: base >= 4.0.0.0, array
966     exposed-modules:
967         Data.Graph
968         Data.IntMap
969}
970
971Context:
972
973[Use left/right rather than old/new to describe the arguments to unionWithKey
974Ian Lynagh <igloo@earth.li>**20090208192132
975 Fixes trac #3002.
976]
977[help nhc98 by making import decl more explicit
978Malcolm.Wallace@cs.york.ac.uk**20090203142144]
979[Add instance Data.Traversable for IntMap
980Matti Niemenmaa <matti.niemenmaa+darcs@iki.fi>**20090116190353
981 Ignore-this: df88a286935926aecec3f8a5dd291699
982]
983[Require Cabal version >= 1.6
984Ian Lynagh <igloo@earth.li>**20090122011256]
985[Add "bug-reports" and "source-repository" info to the Cabal file
986Ian Lynagh <igloo@earth.li>**20090121182106]
987[Fix warnings in containers
988Ian Lynagh <igloo@earth.li>**20090116200251]
989[optimize IntMap/IntSet findMin/findMax
990sedillard@gmail.com**20081002152055]
991[O(n) fromAscList IntSet / IntMap
992sedillard@gmail.com**20080521195941
993 
994 Added algorithm by Scott Dillard and Bertram Felgenhauer to build IntSets and
995 IntMaps from sorted input in linear time. Also changed quickcheck prop_Ordered
996 (no longer a tautology!) to include negative and duplicate keys.
997 
998]
999[correct type for IntMap.intersectionWith[Key]
1000sedillard@gmail.com**20081002144828]
1001[Export mapAccumRWithKey from Map and IntMap (Trac #2769)
1002matti.niemenmaa+darcs@iki.fi**20081210160205]
1003[Bump the version number to 0.2.0.1, to work-around cabal-install problems
1004Ian Lynagh <igloo@earth.li>**20081212201829]
1005[Fix #2760: change mkNorepType to mkNoRepType
1006'Jose Pedro Magalhaes <jpm@cs.uu.nl>'**20081202083424]
1007[Doc fix, from hackage trac #378
1008Ian Lynagh <igloo@earth.li>**20081024143949]
1009[import Data.Data instead of Data.Generics.*, eliminating the dependency on syb
1010Ross Paterson <ross@soi.city.ac.uk>**20081005002559]
1011[fixed typo in highestBitMask
1012sedillard@gmail.com**20081002215438]
1013[export Data.Map.toDescList, foldlWithKey, and foldrWithKey (trac ticket 2580)
1014qdunkan@gmail.com**20080922213200
1015 
1016 toDescList was previously implemented, but not exported.
1017 
1018 foldlWithKey was previously implemented, but not exported.  It can be used to
1019 implement toDescList.
1020 
1021 foldrWithKey is already exported as foldWithKey, but foldrWithKey is explicitly
1022 the mirror of foldlWithKey, and foldWithKey kept for compatibility.
1023]
1024[Bump version number to 0.2.0.0
1025Ian Lynagh <igloo@earth.li>**20080920160016]
1026[TAG 6.10 branch has been forked
1027Ian Lynagh <igloo@earth.li>**20080919123438]
1028[Fixed typo in updateMinWithKey / updateMaxWithKey
1029sedillard@gmail.com**20080704054350]
1030[follow library changes
1031Ian Lynagh <igloo@earth.li>**20080903223610]
1032[add include/Typeable.h to extra-source-files
1033Ross Paterson <ross@soi.city.ac.uk>**20080831181402]
1034[fix cabal build-depends for nhc98
1035Malcolm.Wallace@cs.york.ac.uk**20080828104248]
1036[Add a dep on syb
1037Ian Lynagh <igloo@earth.li>**20080825214314]
1038[add category field
1039Ross Paterson <ross@soi.city.ac.uk>**20080824003013]
1040[we depend on st, now split off from base
1041Ian Lynagh <igloo@earth.li>**20080823223053]
1042[specialize functions that fail in a Monad to Maybe (proposal #2309)
1043Ross Paterson <ross@soi.city.ac.uk>**20080722154812
1044 
1045 Specialize functions signatures like
1046 
1047        lookup :: (Monad m, Ord k) => k -> Map k a -> m a
1048 to
1049        lookup :: (Ord k) => k -> Map k a -> Maybe a
1050 
1051 for simplicity and safety.  No information is lost, as each of these
1052 functions had only one use of fail, which is now changed to Nothing.
1053]
1054[tighter description of split (addresses #2447)
1055Ross Paterson <ross@soi.city.ac.uk>**20080717064838]
1056[Make warning-clean with GHC again
1057Ian Lynagh <igloo@earth.li>**20080623232023
1058 With any luck we have now converged on a solution that works everywhere!
1059]
1060[Undo more Data.Typeable-related breakage for non-ghc.
1061Malcolm.Wallace@cs.york.ac.uk**20080623092757]
1062[Placate GHC with explicit import lists
1063Ian Lynagh <igloo@earth.li>**20080620183926]
1064[undo breakage caused by -Wall cleaning
1065Malcolm.Wallace@cs.york.ac.uk**20080620093922
1066 The import of Data.Typeable is still required, at least for non-GHC.
1067]
1068[Make the package -Wall clean
1069Ian Lynagh <igloo@earth.li>**20080618233627]
1070[List particular extensions rather than -fglasgow-exts
1071Ian Lynagh <igloo@earth.li>**20080616232035]
1072[Avoid using deprecated flags
1073Ian Lynagh <igloo@earth.li>**20080616145241]
1074[TAG 2008-05-28
1075Ian Lynagh <igloo@earth.li>**20080528004309]
1076Patch bundle hash:
107734a6b333944f7de1e11f31999b2894092a7f0acc