Add warning about Seq size.
[packages/containers.git] / Data / Sequence.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__
3 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 703
6 {-# LANGUAGE Trustworthy #-}
7 #endif
8 #if __GLASGOW_HASKELL__ >= 708
9 {-# LANGUAGE TypeFamilies #-}
10 #endif
11
12 #include "containers.h"
13
14 -----------------------------------------------------------------------------
15 -- |
16 -- Module : Data.Sequence
17 -- Copyright : (c) Ross Paterson 2005
18 -- (c) Louis Wasserman 2009
19 -- (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and
20 -- Milan Straka 2014
21 -- License : BSD-style
22 -- Maintainer : libraries@haskell.org
23 -- Stability : experimental
24 -- Portability : portable
25 --
26 -- General purpose finite sequences.
27 -- Apart from being finite and having strict operations, sequences
28 -- also differ from lists in supporting a wider variety of operations
29 -- efficiently.
30 --
31 -- An amortized running time is given for each operation, with /n/ referring
32 -- to the length of the sequence and /i/ being the integral index used by
33 -- some operations. These bounds hold even in a persistent (shared) setting.
34 --
35 -- The implementation uses 2-3 finger trees annotated with sizes,
36 -- as described in section 4.2 of
37 --
38 -- * Ralf Hinze and Ross Paterson,
39 -- \"Finger trees: a simple general-purpose data structure\",
40 -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
41 -- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>
42 --
43 -- /Note/: Many of these operations have the same names as similar
44 -- operations on lists in the "Prelude". The ambiguity may be resolved
45 -- using either qualification or the @hiding@ clause.
46 --
47 -- /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@. Violation
48 -- of this condition is not detected and if the size limit is exceeded, the
49 -- behaviour of the sequence is undefined. This is unlikely to occur in most
50 -- applications, but some care may be required when using '><', '<*>', '*>', or
51 -- '>>', particularly repeatedly and particularly in combination with
52 -- 'replicate' or 'fromFunction'.
53 --
54 -----------------------------------------------------------------------------
55
56 module Data.Sequence (
57 #if !defined(TESTING)
58 Seq,
59 #else
60 Seq(..), Elem(..), FingerTree(..), Node(..), Digit(..),
61 #endif
62 -- * Construction
63 empty, -- :: Seq a
64 singleton, -- :: a -> Seq a
65 (<|), -- :: a -> Seq a -> Seq a
66 (|>), -- :: Seq a -> a -> Seq a
67 (><), -- :: Seq a -> Seq a -> Seq a
68 fromList, -- :: [a] -> Seq a
69 fromFunction, -- :: Int -> (Int -> a) -> Seq a
70 fromArray, -- :: Ix i => Array i a -> Seq a
71 -- ** Repetition
72 replicate, -- :: Int -> a -> Seq a
73 replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)
74 replicateM, -- :: Monad m => Int -> m a -> m (Seq a)
75 -- ** Iterative construction
76 iterateN, -- :: Int -> (a -> a) -> a -> Seq a
77 unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a
78 unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
79 -- * Deconstruction
80 -- | Additional functions for deconstructing sequences are available
81 -- via the 'Foldable' instance of 'Seq'.
82
83 -- ** Queries
84 null, -- :: Seq a -> Bool
85 length, -- :: Seq a -> Int
86 -- ** Views
87 ViewL(..),
88 viewl, -- :: Seq a -> ViewL a
89 ViewR(..),
90 viewr, -- :: Seq a -> ViewR a
91 -- * Scans
92 scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a
93 scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a
94 scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b
95 scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a
96 -- * Sublists
97 tails, -- :: Seq a -> Seq (Seq a)
98 inits, -- :: Seq a -> Seq (Seq a)
99 -- ** Sequential searches
100 takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
101 takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
102 dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
103 dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
104 spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
105 spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
106 breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
107 breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
108 partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
109 filter, -- :: (a -> Bool) -> Seq a -> Seq a
110 -- * Sorting
111 sort, -- :: Ord a => Seq a -> Seq a
112 sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
113 unstableSort, -- :: Ord a => Seq a -> Seq a
114 unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
115 -- * Indexing
116 index, -- :: Seq a -> Int -> a
117 adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
118 update, -- :: Int -> a -> Seq a -> Seq a
119 take, -- :: Int -> Seq a -> Seq a
120 drop, -- :: Int -> Seq a -> Seq a
121 splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
122 -- ** Indexing with predicates
123 -- | These functions perform sequential searches from the left
124 -- or right ends of the sequence, returning indices of matching
125 -- elements.
126 elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int
127 elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]
128 elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int
129 elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]
130 findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int
131 findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]
132 findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
133 findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
134 -- * Folds
135 -- | General folds are available via the 'Foldable' instance of 'Seq'.
136 foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
137 foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
138 -- * Transformations
139 mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b
140 reverse, -- :: Seq a -> Seq a
141 -- ** Zips
142 zip, -- :: Seq a -> Seq b -> Seq (a, b)
143 zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
144 zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
145 zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
146 zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
147 zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
148 #if TESTING
149 Sized(..),
150 deep,
151 node2,
152 node3,
153 #endif
154 ) where
155
156 import Prelude hiding (
157 Functor(..),
158 #if MIN_VERSION_base(4,8,0)
159 Applicative, foldMap, Monoid,
160 #endif
161 null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
162 scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
163 takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
164 import qualified Data.List
165 import Control.Applicative (Applicative(..), (<$>), Alternative,
166 WrappedMonad(..), liftA, liftA2, liftA3)
167 import qualified Control.Applicative as Applicative (Alternative(..))
168 import Control.DeepSeq (NFData(rnf))
169 import Control.Monad (MonadPlus(..), ap)
170 import Data.Monoid (Monoid(..))
171 import Data.Functor (Functor(..))
172 import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap), foldl', toList)
173 #if MIN_VERSION_base(4,8,0)
174 import Data.Foldable (foldr')
175 #endif
176 import Data.Traversable
177 import Data.Typeable
178
179 -- GHC specific stuff
180 #ifdef __GLASGOW_HASKELL__
181 import GHC.Exts (build)
182 import Text.Read (Lexeme(Ident), lexP, parens, prec,
183 readPrec, readListPrec, readListPrecDefault)
184 import Data.Data
185 #endif
186
187 -- Array stuff, with GHC.Arr on GHC
188 import Data.Array (Ix, Array)
189 #ifdef __GLASGOW_HASKELL__
190 import qualified GHC.Arr
191 #endif
192
193 -- Coercion on GHC 7.8+
194 #if __GLASGOW_HASKELL__ >= 708
195 import Data.Coerce
196 import qualified GHC.Exts
197 #else
198 #endif
199
200 -- Identity functor on base 4.8 (GHC 7.10+)
201 #if MIN_VERSION_base(4,8,0)
202 import Data.Functor.Identity (Identity(..))
203 #endif
204
205
206 infixr 5 `consTree`
207 infixl 5 `snocTree`
208 infixr 5 `appendTree0`
209
210 infixr 5 ><
211 infixr 5 <|, :<
212 infixl 5 |>, :>
213
214 class Sized a where
215 size :: a -> Int
216
217 -- | General-purpose finite sequences.
218 newtype Seq a = Seq (FingerTree (Elem a))
219
220 instance Functor Seq where
221 fmap = fmapSeq
222 #ifdef __GLASGOW_HASKELL__
223 x <$ s = replicate (length s) x
224 #endif
225
226 fmapSeq :: (a -> b) -> Seq a -> Seq b
227 fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
228 #ifdef __GLASGOW_HASKELL__
229 {-# NOINLINE [1] fmapSeq #-}
230 {-# RULES
231 "fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs
232 #-}
233 #endif
234 #if __GLASGOW_HASKELL__ >= 709
235 -- Safe coercions were introduced in 7.8, but did not work well with RULES yet.
236 {-# RULES
237 "fmapSeq/coerce" fmapSeq coerce = coerce
238 #-}
239 #endif
240
241 instance Foldable Seq where
242 foldMap f (Seq xs) = foldMap (foldMap f) xs
243 foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
244 foldl f z (Seq xs) = foldl (foldl f) z xs
245
246 foldr1 f (Seq xs) = getElem (foldr1 f' xs)
247 where f' (Elem x) (Elem y) = Elem (f x y)
248
249 foldl1 f (Seq xs) = getElem (foldl1 f' xs)
250 where f' (Elem x) (Elem y) = Elem (f x y)
251
252 #if MIN_VERSION_base(4,8,0)
253 length = length
254 {-# INLINE length #-}
255 null = null
256 {-# INLINE null #-}
257 #endif
258
259 instance Traversable Seq where
260 traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
261
262 instance NFData a => NFData (Seq a) where
263 rnf (Seq xs) = rnf xs
264
265 instance Monad Seq where
266 return = singleton
267 xs >>= f = foldl' add empty xs
268 where add ys x = ys >< f x
269 (>>) = (*>)
270
271 instance Applicative Seq where
272 pure = singleton
273
274 Seq Empty <*> xs = xs `seq` empty
275 fs <*> Seq Empty = fs `seq` empty
276 fs <*> Seq (Single (Elem x)) = fmap ($ x) fs
277 fs <*> xs
278 | length fs < 4 = foldl' add empty fs
279 where add ys f = ys >< fmap f xs
280 fs <*> xs | length xs < 4 = apShort fs xs
281 fs <*> xs = apty fs xs
282
283 xs *> ys = replicateSeq (length xs) ys
284
285 -- <*> when the length of the first argument is at least two and
286 -- the length of the second is two or three.
287 apShort :: Seq (a -> b) -> Seq a -> Seq b
288 apShort (Seq fs) xs = Seq $ case toList xs of
289 [a,b] -> ap2FT fs (a,b)
290 [a,b,c] -> ap3FT fs (a,b,c)
291 _ -> error "apShort: not 2-3"
292
293 ap2FT :: FingerTree (Elem (a->b)) -> (a,a) -> FingerTree (Elem b)
294 ap2FT fs (x,y) = Deep (size fs * 2)
295 (Two (Elem $ firstf x) (Elem $ firstf y))
296 (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) m)
297 (Two (Elem $ lastf x) (Elem $ lastf y))
298 where
299 (Elem firstf, m, Elem lastf) = trimTree fs
300
301 ap3FT :: FingerTree (Elem (a->b)) -> (a,a,a) -> FingerTree (Elem b)
302 ap3FT fs (x,y,z) = Deep (size fs * 3)
303 (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))
304 (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) m)
305 (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))
306 where
307 (Elem firstf, m, Elem lastf) = trimTree fs
308
309 -- <*> when the length of each argument is at least four.
310 apty :: Seq (a -> b) -> Seq a -> Seq b
311 apty (Seq fs) (Seq xs@Deep{}) = Seq $
312 Deep (s' * size fs)
313 (fmap (fmap firstf) pr')
314 (aptyMiddle (fmap firstf) (fmap lastf) fmap fs' xs')
315 (fmap (fmap lastf) sf')
316 where
317 (Elem firstf, fs', Elem lastf) = trimTree fs
318 xs'@(Deep s' pr' _m' sf') = rigidify xs
319 apty _ _ = error "apty: expects a Deep constructor"
320
321 -- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@.
322 -- It produces the center part of a finger tree, with a prefix corresponding
323 -- to the prefix of @xs@ and a suffix corresponding to the suffix of @xs@
324 -- omitted; the missing suffix and prefix are added by the caller.
325 -- For the recursive call, it squashes the prefix and the suffix into
326 -- the center tree. Once it gets to the bottom, it turns the tree into
327 -- a 2-3 tree, applies 'mapMulFT' to produce the main body, and glues all
328 -- the pieces together.
329 aptyMiddle
330 :: Sized c =>
331 (c -> d)
332 -> (c -> d)
333 -> ((a -> b) -> c -> d)
334 -> FingerTree (Elem (a -> b))
335 -> FingerTree c
336 -> FingerTree (Node d)
337 -- Not at the bottom yet
338 aptyMiddle firstf
339 lastf
340 map23
341 fs
342 (Deep s pr (Deep sm prm mm sfm) sf)
343 = Deep (sm + s * (size fs + 1)) -- note: sm = s - size pr - size sf
344 (fmap (fmap firstf) prm)
345 (aptyMiddle (fmap firstf)
346 (fmap lastf)
347 (\f -> fmap (map23 f))
348 fs
349 (Deep s (squashL pr prm) mm (squashR sfm sf)))
350 (fmap (fmap lastf) sfm)
351
352 -- At the bottom. Note that these appendTree0 calls are very cheap, because in
353 -- each case, one of the arguments is guaranteed to be Empty or Single.
354 aptyMiddle firstf
355 lastf
356 map23
357 fs
358 (Deep s pr m sf)
359 = fmap (fmap firstf) m `appendTree0`
360 ((fmap firstf (digitToNode sf)
361 `consTree` middle)
362 `snocTree` fmap lastf (digitToNode pr))
363 `appendTree0` fmap (fmap lastf) m
364 where middle = case trimTree $ mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs of
365 (firstMapped, restMapped, lastMapped) ->
366 Deep (size firstMapped + size restMapped + size lastMapped)
367 (nodeToDigit firstMapped) restMapped (nodeToDigit lastMapped)
368 converted = case m of
369 Empty -> Node2 s lconv rconv
370 Single q -> Node3 s lconv q rconv
371 Deep{} -> error "aptyMiddle: impossible"
372 lconv = digitToNode pr
373 rconv = digitToNode sf
374
375 aptyMiddle _ _ _ _ _ = error "aptyMiddle: expected Deep finger tree"
376
377 {-# SPECIALIZE
378 aptyMiddle
379 :: (Node c -> d)
380 -> (Node c -> d)
381 -> ((a -> b) -> Node c -> d)
382 -> FingerTree (Elem (a -> b))
383 -> FingerTree (Node c)
384 -> FingerTree (Node d)
385 #-}
386 {-# SPECIALIZE
387 aptyMiddle
388 :: (Elem c -> d)
389 -> (Elem c -> d)
390 -> ((a -> b) -> Elem c -> d)
391 -> FingerTree (Elem (a -> b))
392 -> FingerTree (Elem c)
393 -> FingerTree (Node d)
394 #-}
395
396 digitToNode :: Sized a => Digit a -> Node a
397 digitToNode (Two a b) = node2 a b
398 digitToNode (Three a b c) = node3 a b c
399 digitToNode _ = error "digitToNode: not representable as a node"
400
401 type Digit23 = Digit
402 type Digit12 = Digit
403
404 -- Squash the first argument down onto the left side of the second.
405 squashL :: Sized a => Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)
406 squashL (Two a b) (One n) = Two (node2 a b) n
407 squashL (Two a b) (Two n1 n2) = Three (node2 a b) n1 n2
408 squashL (Three a b c) (One n) = Two (node3 a b c) n
409 squashL (Three a b c) (Two n1 n2) = Three (node3 a b c) n1 n2
410 squashL _ _ = error "squashL: wrong digit types"
411
412 -- Squash the second argument down onto the right side of the first
413 squashR :: Sized a => Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)
414 squashR (One n) (Two a b) = Two n (node2 a b)
415 squashR (Two n1 n2) (Two a b) = Three n1 n2 (node2 a b)
416 squashR (One n) (Three a b c) = Two n (node3 a b c)
417 squashR (Two n1 n2) (Three a b c) = Three n1 n2 (node3 a b c)
418 squashR _ _ = error "squashR: wrong digit types"
419
420 -- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size
421 -- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the
422 -- function is applied to the "leaves" of the 'FingerTree' (i.e., given a
423 -- @FingerTree (Elem a)@, it applies the function to elements of type @Elem
424 -- a@), replacing the leaves with subtrees of at least the same height, e.g.,
425 -- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations
426 -- match up properly.
427 mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b
428 mapMulFT _ _ Empty = Empty
429 mapMulFT _mul f (Single a) = Single (f a)
430 mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)
431
432 mapMulNode :: Int -> (a -> b) -> Node a -> Node b
433 mapMulNode mul f (Node2 s a b) = Node2 (mul * s) (f a) (f b)
434 mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)
435
436
437 trimTree :: Sized a => FingerTree a -> (a, FingerTree a, a)
438 trimTree Empty = error "trim: empty tree"
439 trimTree Single{} = error "trim: singleton"
440 trimTree t = case splitTree 0 t of
441 Split _ hd r ->
442 case splitTree (size r - 1) r of
443 Split m tl _ -> (hd, m, tl)
444
445 -- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree'
446 -- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have
447 -- only 'Two' and 'Three' digits at the top level and only 'One' and 'Two'
448 -- digits elsewhere. It gives an error if the tree has fewer than four
449 -- elements.
450 rigidify :: Sized a => FingerTree a -> FingerTree a
451 -- Note that 'rigidify' may call itself, but it will do so at most
452 -- once: each call to 'rigidify' will either fix the whole tree or fix one digit
453 -- and leave the other alone. The patterns below just fix up the top level of
454 -- the tree; 'rigidify' delegates the hard work to 'thin'.
455
456 -- The top of the tree is fine.
457 rigidify (Deep s pr@Two{} m sf@Three{}) = Deep s pr (thin m) sf
458 rigidify (Deep s pr@Three{} m sf@Three{}) = Deep s pr (thin m) sf
459 rigidify (Deep s pr@Two{} m sf@Two{}) = Deep s pr (thin m) sf
460 rigidify (Deep s pr@Three{} m sf@Two{}) = Deep s pr (thin m) sf
461
462 -- One of the Digits is a Four.
463 rigidify (Deep s (Four a b c d) m sf) =
464 rigidify $ Deep s (Two a b) (node2 c d `consTree` m) sf
465 rigidify (Deep s pr m (Four a b c d)) =
466 rigidify $ Deep s pr (m `snocTree` node2 a b) (Two c d)
467
468 -- One of the Digits is a One. If the middle is empty, we can only rigidify the
469 -- tree if the other Digit is a Three.
470 rigidify (Deep s (One a) Empty (Three b c d)) = Deep s (Two a b) Empty (Two c d)
471 rigidify (Deep s (One a) m sf) = rigidify $ case viewLTree m of
472 Just2 (Node2 _ b c) m' -> Deep s (Three a b c) m' sf
473 Just2 (Node3 _ b c d) m' -> Deep s (Two a b) (node2 c d `consTree` m') sf
474 Nothing2 -> error "rigidify: small tree"
475 rigidify (Deep s (Three a b c) Empty (One d)) = Deep s (Two a b) Empty (Two c d)
476 rigidify (Deep s pr m (One e)) = rigidify $ case viewRTree m of
477 Just2 m' (Node2 _ a b) -> Deep s pr m' (Three a b e)
478 Just2 m' (Node3 _ a b c) -> Deep s pr (m' `snocTree` node2 a b) (Two c e)
479 Nothing2 -> error "rigidify: small tree"
480 rigidify Empty = error "rigidify: empty tree"
481 rigidify Single{} = error "rigidify: singleton"
482
483 -- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones
484 -- and twos.
485 thin :: Sized a => FingerTree a -> FingerTree a
486 -- Note that 'thin12' will produce a 'Deep' constructor immediately before
487 -- recursively calling 'thin'.
488 thin Empty = Empty
489 thin (Single a) = Single a
490 thin t@(Deep s pr m sf) =
491 case pr of
492 One{} -> thin12 t
493 Two{} -> thin12 t
494 Three a b c -> thin12 $ Deep s (One a) (node2 b c `consTree` m) sf
495 Four a b c d -> thin12 $ Deep s (Two a b) (node2 c d `consTree` m) sf
496
497 thin12 :: Sized a => FingerTree a -> FingerTree a
498 thin12 (Deep s pr m sf@One{}) = Deep s pr (thin m) sf
499 thin12 (Deep s pr m sf@Two{}) = Deep s pr (thin m) sf
500 thin12 (Deep s pr m (Three a b c)) = Deep s pr (thin $ m `snocTree` node2 a b) (One c)
501 thin12 (Deep s pr m (Four a b c d)) = Deep s pr (thin $ m `snocTree` node2 a b) (Two c d)
502 thin12 _ = error "thin12 expects a Deep FingerTree."
503
504
505 instance MonadPlus Seq where
506 mzero = empty
507 mplus = (><)
508
509 instance Alternative Seq where
510 empty = empty
511 (<|>) = (><)
512
513 instance Eq a => Eq (Seq a) where
514 xs == ys = length xs == length ys && toList xs == toList ys
515
516 instance Ord a => Ord (Seq a) where
517 compare xs ys = compare (toList xs) (toList ys)
518
519 #if TESTING
520 instance Show a => Show (Seq a) where
521 showsPrec p (Seq x) = showsPrec p x
522 #else
523 instance Show a => Show (Seq a) where
524 showsPrec p xs = showParen (p > 10) $
525 showString "fromList " . shows (toList xs)
526 #endif
527
528 instance Read a => Read (Seq a) where
529 #ifdef __GLASGOW_HASKELL__
530 readPrec = parens $ prec 10 $ do
531 Ident "fromList" <- lexP
532 xs <- readPrec
533 return (fromList xs)
534
535 readListPrec = readListPrecDefault
536 #else
537 readsPrec p = readParen (p > 10) $ \ r -> do
538 ("fromList",s) <- lex r
539 (xs,t) <- reads s
540 return (fromList xs,t)
541 #endif
542
543 instance Monoid (Seq a) where
544 mempty = empty
545 mappend = (><)
546
547 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
548
549 #if __GLASGOW_HASKELL__
550 instance Data a => Data (Seq a) where
551 gfoldl f z s = case viewl s of
552 EmptyL -> z empty
553 x :< xs -> z (<|) `f` x `f` xs
554
555 gunfold k z c = case constrIndex c of
556 1 -> z empty
557 2 -> k (k (z (<|)))
558 _ -> error "gunfold"
559
560 toConstr xs
561 | null xs = emptyConstr
562 | otherwise = consConstr
563
564 dataTypeOf _ = seqDataType
565
566 dataCast1 f = gcast1 f
567
568 emptyConstr, consConstr :: Constr
569 emptyConstr = mkConstr seqDataType "empty" [] Prefix
570 consConstr = mkConstr seqDataType "<|" [] Infix
571
572 seqDataType :: DataType
573 seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
574 #endif
575
576 -- Finger trees
577
578 data FingerTree a
579 = Empty
580 | Single a
581 | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
582 #if TESTING
583 deriving Show
584 #endif
585
586 instance Sized a => Sized (FingerTree a) where
587 {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
588 {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
589 size Empty = 0
590 size (Single x) = size x
591 size (Deep v _ _ _) = v
592
593 instance Foldable FingerTree where
594 foldMap _ Empty = mempty
595 foldMap f (Single x) = f x
596 foldMap f (Deep _ pr m sf) =
597 foldMap f pr `mappend` (foldMap (foldMap f) m `mappend` foldMap f sf)
598
599 foldr _ z Empty = z
600 foldr f z (Single x) = x `f` z
601 foldr f z (Deep _ pr m sf) =
602 foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
603
604 foldl _ z Empty = z
605 foldl f z (Single x) = z `f` x
606 foldl f z (Deep _ pr m sf) =
607 foldl f (foldl (foldl f) (foldl f z pr) m) sf
608
609 foldr1 _ Empty = error "foldr1: empty sequence"
610 foldr1 _ (Single x) = x
611 foldr1 f (Deep _ pr m sf) =
612 foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
613
614 foldl1 _ Empty = error "foldl1: empty sequence"
615 foldl1 _ (Single x) = x
616 foldl1 f (Deep _ pr m sf) =
617 foldl f (foldl (foldl f) (foldl1 f pr) m) sf
618
619 instance Functor FingerTree where
620 fmap _ Empty = Empty
621 fmap f (Single x) = Single (f x)
622 fmap f (Deep v pr m sf) =
623 Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
624
625 instance Traversable FingerTree where
626 traverse _ Empty = pure Empty
627 traverse f (Single x) = Single <$> f x
628 traverse f (Deep v pr m sf) =
629 Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
630 traverse f sf
631
632 instance NFData a => NFData (FingerTree a) where
633 rnf (Empty) = ()
634 rnf (Single x) = rnf x
635 rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m
636
637 {-# INLINE deep #-}
638 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
639 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
640
641 {-# INLINE pullL #-}
642 pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a
643 pullL s m sf = case viewLTree m of
644 Nothing2 -> digitToTree' s sf
645 Just2 pr m' -> Deep s (nodeToDigit pr) m' sf
646
647 {-# INLINE pullR #-}
648 pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a
649 pullR s pr m = case viewRTree m of
650 Nothing2 -> digitToTree' s pr
651 Just2 m' sf -> Deep s pr m' (nodeToDigit sf)
652
653 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
654 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
655 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
656 deepL Nothing m sf = pullL (size m + size sf) m sf
657 deepL (Just pr) m sf = deep pr m sf
658
659 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
660 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
661 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
662 deepR pr m Nothing = pullR (size m + size pr) pr m
663 deepR pr m (Just sf) = deep pr m sf
664
665 -- Digits
666
667 data Digit a
668 = One a
669 | Two a a
670 | Three a a a
671 | Four a a a a
672 #if TESTING
673 deriving Show
674 #endif
675
676 instance Foldable Digit where
677 foldMap f (One a) = f a
678 foldMap f (Two a b) = f a `mappend` f b
679 foldMap f (Three a b c) = f a `mappend` (f b `mappend` f c)
680 foldMap f (Four a b c d) = f a `mappend` (f b `mappend` (f c `mappend` f d))
681
682 foldr f z (One a) = a `f` z
683 foldr f z (Two a b) = a `f` (b `f` z)
684 foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
685 foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
686
687 foldl f z (One a) = z `f` a
688 foldl f z (Two a b) = (z `f` a) `f` b
689 foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
690 foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
691
692 foldr1 _ (One a) = a
693 foldr1 f (Two a b) = a `f` b
694 foldr1 f (Three a b c) = a `f` (b `f` c)
695 foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
696
697 foldl1 _ (One a) = a
698 foldl1 f (Two a b) = a `f` b
699 foldl1 f (Three a b c) = (a `f` b) `f` c
700 foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
701
702 instance Functor Digit where
703 {-# INLINE fmap #-}
704 fmap f (One a) = One (f a)
705 fmap f (Two a b) = Two (f a) (f b)
706 fmap f (Three a b c) = Three (f a) (f b) (f c)
707 fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
708
709 instance Traversable Digit where
710 {-# INLINE traverse #-}
711 traverse f (One a) = One <$> f a
712 traverse f (Two a b) = Two <$> f a <*> f b
713 traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
714 traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
715
716 instance NFData a => NFData (Digit a) where
717 rnf (One a) = rnf a
718 rnf (Two a b) = rnf a `seq` rnf b
719 rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c
720 rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
721
722 instance Sized a => Sized (Digit a) where
723 {-# INLINE size #-}
724 size = foldl1 (+) . fmap size
725
726 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
727 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
728 digitToTree :: Sized a => Digit a -> FingerTree a
729 digitToTree (One a) = Single a
730 digitToTree (Two a b) = deep (One a) Empty (One b)
731 digitToTree (Three a b c) = deep (Two a b) Empty (One c)
732 digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
733
734 -- | Given the size of a digit and the digit itself, efficiently converts
735 -- it to a FingerTree.
736 digitToTree' :: Int -> Digit a -> FingerTree a
737 digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
738 digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
739 digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
740 digitToTree' n (One a) = n `seq` Single a
741
742 -- Nodes
743
744 data Node a
745 = Node2 {-# UNPACK #-} !Int a a
746 | Node3 {-# UNPACK #-} !Int a a a
747 #if TESTING
748 deriving Show
749 #endif
750
751 instance Foldable Node where
752 foldMap f (Node2 _ a b) = f a `mappend` f b
753 foldMap f (Node3 _ a b c) = f a `mappend` (f b `mappend` f c)
754
755 foldr f z (Node2 _ a b) = a `f` (b `f` z)
756 foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
757
758 foldl f z (Node2 _ a b) = (z `f` a) `f` b
759 foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
760
761 instance Functor Node where
762 {-# INLINE fmap #-}
763 fmap f (Node2 v a b) = Node2 v (f a) (f b)
764 fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
765
766 instance Traversable Node where
767 {-# INLINE traverse #-}
768 traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
769 traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
770
771 instance NFData a => NFData (Node a) where
772 rnf (Node2 _ a b) = rnf a `seq` rnf b
773 rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c
774
775 instance Sized (Node a) where
776 size (Node2 v _ _) = v
777 size (Node3 v _ _ _) = v
778
779 {-# INLINE node2 #-}
780 node2 :: Sized a => a -> a -> Node a
781 node2 a b = Node2 (size a + size b) a b
782
783 {-# INLINE node3 #-}
784 node3 :: Sized a => a -> a -> a -> Node a
785 node3 a b c = Node3 (size a + size b + size c) a b c
786
787 nodeToDigit :: Node a -> Digit a
788 nodeToDigit (Node2 _ a b) = Two a b
789 nodeToDigit (Node3 _ a b c) = Three a b c
790
791 -- Elements
792
793 newtype Elem a = Elem { getElem :: a }
794 #if TESTING
795 deriving Show
796 #endif
797
798 instance Sized (Elem a) where
799 size _ = 1
800
801 instance Functor Elem where
802 #if __GLASGOW_HASKELL__ >= 708
803 -- This cuts the time for <*> by around a fifth.
804 fmap = coerce
805 #else
806 fmap f (Elem x) = Elem (f x)
807 #endif
808
809 instance Foldable Elem where
810 foldMap f (Elem x) = f x
811 foldr f z (Elem x) = f x z
812 foldl f z (Elem x) = f z x
813
814 instance Traversable Elem where
815 traverse f (Elem x) = Elem <$> f x
816
817 instance NFData a => NFData (Elem a) where
818 rnf (Elem x) = rnf x
819
820 -------------------------------------------------------
821 -- Applicative construction
822 -------------------------------------------------------
823 #if !MIN_VERSION_base(4,8,0)
824 newtype Identity a = Identity {runIdentity :: a}
825
826 instance Functor Identity where
827 fmap f (Identity x) = Identity (f x)
828
829 instance Applicative Identity where
830 pure = Identity
831 Identity f <*> Identity x = Identity (f x)
832 #endif
833
834 -- | This is essentially a clone of Control.Monad.State.Strict.
835 newtype State s a = State {runState :: s -> (s, a)}
836
837 instance Functor (State s) where
838 fmap = liftA
839
840 instance Monad (State s) where
841 {-# INLINE return #-}
842 {-# INLINE (>>=) #-}
843 return x = State $ \ s -> (s, x)
844 m >>= k = State $ \ s -> case runState m s of
845 (s', x) -> runState (k x) s'
846
847 instance Applicative (State s) where
848 pure = return
849 (<*>) = ap
850
851 execState :: State s a -> s -> a
852 execState m x = snd (runState m x)
853
854 -- | 'applicativeTree' takes an Applicative-wrapped construction of a
855 -- piece of a FingerTree, assumed to always have the same size (which
856 -- is put in the second argument), and replicates it as many times as
857 -- specified. This is a generalization of 'replicateA', which itself
858 -- is a generalization of many Data.Sequence methods.
859 {-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
860 {-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}
861 -- Special note: the Identity specialization automatically does node sharing,
862 -- reducing memory usage of the resulting tree to /O(log n)/.
863 applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
864 applicativeTree n mSize m = mSize `seq` case n of
865 0 -> pure Empty
866 1 -> fmap Single m
867 2 -> deepA one emptyTree one
868 3 -> deepA two emptyTree one
869 4 -> deepA two emptyTree two
870 5 -> deepA three emptyTree two
871 6 -> deepA three emptyTree three
872 _ -> case n `quotRem` 3 of
873 (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three
874 (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two
875 (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two
876 where
877 one = fmap One m
878 two = liftA2 Two m m
879 three = liftA3 Three m m m
880 deepA = liftA3 (Deep (n * mSize))
881 mSize' = 3 * mSize
882 n3 = liftA3 (Node3 mSize') m m m
883 emptyTree = pure Empty
884
885 ------------------------------------------------------------------------
886 -- Construction
887 ------------------------------------------------------------------------
888
889 -- | /O(1)/. The empty sequence.
890 empty :: Seq a
891 empty = Seq Empty
892
893 -- | /O(1)/. A singleton sequence.
894 singleton :: a -> Seq a
895 singleton x = Seq (Single (Elem x))
896
897 -- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.
898 replicate :: Int -> a -> Seq a
899 replicate n x
900 | n >= 0 = runIdentity (replicateA n (Identity x))
901 | otherwise = error "replicate takes a nonnegative integer argument"
902
903 -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
904 -- /O(log n)/ calls to '<*>' and 'pure'.
905 --
906 -- > replicateA n x = sequenceA (replicate n x)
907 replicateA :: Applicative f => Int -> f a -> f (Seq a)
908 replicateA n x
909 | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
910 | otherwise = error "replicateA takes a nonnegative integer argument"
911
912 -- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
913 --
914 -- > replicateM n x = sequence (replicate n x)
915 replicateM :: Monad m => Int -> m a -> m (Seq a)
916 replicateM n x
917 | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
918 | otherwise = error "replicateM takes a nonnegative integer argument"
919
920 -- | @'replicateSeq' n xs@ concatenates @n@ copies of @xs@.
921 replicateSeq :: Int -> Seq a -> Seq a
922 replicateSeq n s
923 | n < 0 = error "replicateSeq takes a nonnegative integer argument"
924 | n == 0 = empty
925 | otherwise = go n s
926 where
927 -- Invariant: k >= 1
928 go 1 xs = xs
929 go k xs | even k = kxs
930 | otherwise = xs >< kxs
931 where kxs = go (k `quot` 2) $! (xs >< xs)
932
933 -- | /O(1)/. Add an element to the left end of a sequence.
934 -- Mnemonic: a triangle with the single element at the pointy end.
935 (<|) :: a -> Seq a -> Seq a
936 x <| Seq xs = Seq (Elem x `consTree` xs)
937
938 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
939 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
940 consTree :: Sized a => a -> FingerTree a -> FingerTree a
941 consTree a Empty = Single a
942 consTree a (Single b) = deep (One a) Empty (One b)
943 consTree a (Deep s (Four b c d e) m sf) = m `seq`
944 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
945 consTree a (Deep s (Three b c d) m sf) =
946 Deep (size a + s) (Four a b c d) m sf
947 consTree a (Deep s (Two b c) m sf) =
948 Deep (size a + s) (Three a b c) m sf
949 consTree a (Deep s (One b) m sf) =
950 Deep (size a + s) (Two a b) m sf
951
952 -- | /O(1)/. Add an element to the right end of a sequence.
953 -- Mnemonic: a triangle with the single element at the pointy end.
954 (|>) :: Seq a -> a -> Seq a
955 Seq xs |> x = Seq (xs `snocTree` Elem x)
956
957 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
958 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
959 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
960 snocTree Empty a = Single a
961 snocTree (Single a) b = deep (One a) Empty (One b)
962 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
963 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
964 snocTree (Deep s pr m (Three a b c)) d =
965 Deep (s + size d) pr m (Four a b c d)
966 snocTree (Deep s pr m (Two a b)) c =
967 Deep (s + size c) pr m (Three a b c)
968 snocTree (Deep s pr m (One a)) b =
969 Deep (s + size b) pr m (Two a b)
970
971 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
972 (><) :: Seq a -> Seq a -> Seq a
973 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
974
975 -- The appendTree/addDigits gunk below is machine generated
976
977 {-# SPECIALIZE appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
978 {-# SPECIALIZE appendTree0 :: FingerTree (Node a) -> FingerTree (Node a) -> FingerTree (Node a) #-}
979 appendTree0 :: Sized a => FingerTree a -> FingerTree a -> FingerTree a
980 appendTree0 Empty xs =
981 xs
982 appendTree0 xs Empty =
983 xs
984 appendTree0 (Single x) xs =
985 x `consTree` xs
986 appendTree0 xs (Single x) =
987 xs `snocTree` x
988 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
989 Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
990
991 {-# SPECIALIZE addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a)) #-}
992 {-# SPECIALIZE addDigits0 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a)) #-}
993 addDigits0 :: Sized a => FingerTree (Node a) -> Digit a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a)
994 addDigits0 m1 (One a) (One b) m2 =
995 appendTree1 m1 (node2 a b) m2
996 addDigits0 m1 (One a) (Two b c) m2 =
997 appendTree1 m1 (node3 a b c) m2
998 addDigits0 m1 (One a) (Three b c d) m2 =
999 appendTree2 m1 (node2 a b) (node2 c d) m2
1000 addDigits0 m1 (One a) (Four b c d e) m2 =
1001 appendTree2 m1 (node3 a b c) (node2 d e) m2
1002 addDigits0 m1 (Two a b) (One c) m2 =
1003 appendTree1 m1 (node3 a b c) m2
1004 addDigits0 m1 (Two a b) (Two c d) m2 =
1005 appendTree2 m1 (node2 a b) (node2 c d) m2
1006 addDigits0 m1 (Two a b) (Three c d e) m2 =
1007 appendTree2 m1 (node3 a b c) (node2 d e) m2
1008 addDigits0 m1 (Two a b) (Four c d e f) m2 =
1009 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1010 addDigits0 m1 (Three a b c) (One d) m2 =
1011 appendTree2 m1 (node2 a b) (node2 c d) m2
1012 addDigits0 m1 (Three a b c) (Two d e) m2 =
1013 appendTree2 m1 (node3 a b c) (node2 d e) m2
1014 addDigits0 m1 (Three a b c) (Three d e f) m2 =
1015 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1016 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
1017 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1018 addDigits0 m1 (Four a b c d) (One e) m2 =
1019 appendTree2 m1 (node3 a b c) (node2 d e) m2
1020 addDigits0 m1 (Four a b c d) (Two e f) m2 =
1021 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1022 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
1023 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1024 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
1025 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1026
1027 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1028 appendTree1 Empty a xs =
1029 a `consTree` xs
1030 appendTree1 xs a Empty =
1031 xs `snocTree` a
1032 appendTree1 (Single x) a xs =
1033 x `consTree` a `consTree` xs
1034 appendTree1 xs a (Single x) =
1035 xs `snocTree` a `snocTree` x
1036 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
1037 Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
1038
1039 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1040 addDigits1 m1 (One a) b (One c) m2 =
1041 appendTree1 m1 (node3 a b c) m2
1042 addDigits1 m1 (One a) b (Two c d) m2 =
1043 appendTree2 m1 (node2 a b) (node2 c d) m2
1044 addDigits1 m1 (One a) b (Three c d e) m2 =
1045 appendTree2 m1 (node3 a b c) (node2 d e) m2
1046 addDigits1 m1 (One a) b (Four c d e f) m2 =
1047 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1048 addDigits1 m1 (Two a b) c (One d) m2 =
1049 appendTree2 m1 (node2 a b) (node2 c d) m2
1050 addDigits1 m1 (Two a b) c (Two d e) m2 =
1051 appendTree2 m1 (node3 a b c) (node2 d e) m2
1052 addDigits1 m1 (Two a b) c (Three d e f) m2 =
1053 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1054 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
1055 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1056 addDigits1 m1 (Three a b c) d (One e) m2 =
1057 appendTree2 m1 (node3 a b c) (node2 d e) m2
1058 addDigits1 m1 (Three a b c) d (Two e f) m2 =
1059 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1060 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
1061 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1062 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
1063 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1064 addDigits1 m1 (Four a b c d) e (One f) m2 =
1065 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1066 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
1067 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1068 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
1069 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1070 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
1071 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1072
1073 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1074 appendTree2 Empty a b xs =
1075 a `consTree` b `consTree` xs
1076 appendTree2 xs a b Empty =
1077 xs `snocTree` a `snocTree` b
1078 appendTree2 (Single x) a b xs =
1079 x `consTree` a `consTree` b `consTree` xs
1080 appendTree2 xs a b (Single x) =
1081 xs `snocTree` a `snocTree` b `snocTree` x
1082 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
1083 Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
1084
1085 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1086 addDigits2 m1 (One a) b c (One d) m2 =
1087 appendTree2 m1 (node2 a b) (node2 c d) m2
1088 addDigits2 m1 (One a) b c (Two d e) m2 =
1089 appendTree2 m1 (node3 a b c) (node2 d e) m2
1090 addDigits2 m1 (One a) b c (Three d e f) m2 =
1091 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1092 addDigits2 m1 (One a) b c (Four d e f g) m2 =
1093 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1094 addDigits2 m1 (Two a b) c d (One e) m2 =
1095 appendTree2 m1 (node3 a b c) (node2 d e) m2
1096 addDigits2 m1 (Two a b) c d (Two e f) m2 =
1097 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1098 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
1099 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1100 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
1101 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1102 addDigits2 m1 (Three a b c) d e (One f) m2 =
1103 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1104 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
1105 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1106 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
1107 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1108 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
1109 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1110 addDigits2 m1 (Four a b c d) e f (One g) m2 =
1111 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1112 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
1113 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1114 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
1115 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1116 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
1117 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1118
1119 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1120 appendTree3 Empty a b c xs =
1121 a `consTree` b `consTree` c `consTree` xs
1122 appendTree3 xs a b c Empty =
1123 xs `snocTree` a `snocTree` b `snocTree` c
1124 appendTree3 (Single x) a b c xs =
1125 x `consTree` a `consTree` b `consTree` c `consTree` xs
1126 appendTree3 xs a b c (Single x) =
1127 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
1128 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
1129 Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
1130
1131 addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1132 addDigits3 m1 (One a) b c d (One e) m2 =
1133 appendTree2 m1 (node3 a b c) (node2 d e) m2
1134 addDigits3 m1 (One a) b c d (Two e f) m2 =
1135 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1136 addDigits3 m1 (One a) b c d (Three e f g) m2 =
1137 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1138 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
1139 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1140 addDigits3 m1 (Two a b) c d e (One f) m2 =
1141 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1142 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
1143 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1144 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
1145 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1146 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
1147 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1148 addDigits3 m1 (Three a b c) d e f (One g) m2 =
1149 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1150 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
1151 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1152 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
1153 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1154 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
1155 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1156 addDigits3 m1 (Four a b c d) e f g (One h) m2 =
1157 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1158 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
1159 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1160 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
1161 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1162 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
1163 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1164
1165 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1166 appendTree4 Empty a b c d xs =
1167 a `consTree` b `consTree` c `consTree` d `consTree` xs
1168 appendTree4 xs a b c d Empty =
1169 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
1170 appendTree4 (Single x) a b c d xs =
1171 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
1172 appendTree4 xs a b c d (Single x) =
1173 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
1174 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
1175 Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
1176
1177 addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1178 addDigits4 m1 (One a) b c d e (One f) m2 =
1179 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1180 addDigits4 m1 (One a) b c d e (Two f g) m2 =
1181 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1182 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
1183 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1184 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
1185 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1186 addDigits4 m1 (Two a b) c d e f (One g) m2 =
1187 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1188 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
1189 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1190 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
1191 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1192 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
1193 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1194 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
1195 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1196 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
1197 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1198 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
1199 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1200 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
1201 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1202 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
1203 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1204 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
1205 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1206 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
1207 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1208 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
1209 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
1210
1211 -- | Builds a sequence from a seed value. Takes time linear in the
1212 -- number of generated elements. /WARNING:/ If the number of generated
1213 -- elements is infinite, this method will not terminate.
1214 unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
1215 unfoldr f = unfoldr' empty
1216 -- uses tail recursion rather than, for instance, the List implementation.
1217 where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
1218
1219 -- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.
1220 unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
1221 unfoldl f = unfoldl' empty
1222 where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
1223
1224 -- | /O(n)/. Constructs a sequence by repeated application of a function
1225 -- to a seed value.
1226 --
1227 -- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
1228 iterateN :: Int -> (a -> a) -> a -> Seq a
1229 iterateN n f x
1230 | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
1231 | otherwise = error "iterateN takes a nonnegative integer argument"
1232
1233 ------------------------------------------------------------------------
1234 -- Deconstruction
1235 ------------------------------------------------------------------------
1236
1237 -- | /O(1)/. Is this the empty sequence?
1238 null :: Seq a -> Bool
1239 null (Seq Empty) = True
1240 null _ = False
1241
1242 -- | /O(1)/. The number of elements in the sequence.
1243 length :: Seq a -> Int
1244 length (Seq xs) = size xs
1245
1246 -- Views
1247
1248 data Maybe2 a b = Nothing2 | Just2 a b
1249
1250 -- | View of the left end of a sequence.
1251 data ViewL a
1252 = EmptyL -- ^ empty sequence
1253 | a :< Seq a -- ^ leftmost element and the rest of the sequence
1254 #if __GLASGOW_HASKELL__
1255 deriving (Eq, Ord, Show, Read, Data)
1256 #else
1257 deriving (Eq, Ord, Show, Read)
1258 #endif
1259
1260 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
1261
1262 instance Functor ViewL where
1263 {-# INLINE fmap #-}
1264 fmap _ EmptyL = EmptyL
1265 fmap f (x :< xs) = f x :< fmap f xs
1266
1267 instance Foldable ViewL where
1268 foldr _ z EmptyL = z
1269 foldr f z (x :< xs) = f x (foldr f z xs)
1270
1271 foldl _ z EmptyL = z
1272 foldl f z (x :< xs) = foldl f (f z x) xs
1273
1274 foldl1 _ EmptyL = error "foldl1: empty view"
1275 foldl1 f (x :< xs) = foldl f x xs
1276
1277 instance Traversable ViewL where
1278 traverse _ EmptyL = pure EmptyL
1279 traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
1280
1281 -- | /O(1)/. Analyse the left end of a sequence.
1282 viewl :: Seq a -> ViewL a
1283 viewl (Seq xs) = case viewLTree xs of
1284 Nothing2 -> EmptyL
1285 Just2 (Elem x) xs' -> x :< Seq xs'
1286
1287 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
1288 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
1289 viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
1290 viewLTree Empty = Nothing2
1291 viewLTree (Single a) = Just2 a Empty
1292 viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)
1293 viewLTree (Deep s (Two a b) m sf) =
1294 Just2 a (Deep (s - size a) (One b) m sf)
1295 viewLTree (Deep s (Three a b c) m sf) =
1296 Just2 a (Deep (s - size a) (Two b c) m sf)
1297 viewLTree (Deep s (Four a b c d) m sf) =
1298 Just2 a (Deep (s - size a) (Three b c d) m sf)
1299
1300 -- | View of the right end of a sequence.
1301 data ViewR a
1302 = EmptyR -- ^ empty sequence
1303 | Seq a :> a -- ^ the sequence minus the rightmost element,
1304 -- and the rightmost element
1305 #if __GLASGOW_HASKELL__
1306 deriving (Eq, Ord, Show, Read, Data)
1307 #else
1308 deriving (Eq, Ord, Show, Read)
1309 #endif
1310
1311 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
1312
1313 instance Functor ViewR where
1314 {-# INLINE fmap #-}
1315 fmap _ EmptyR = EmptyR
1316 fmap f (xs :> x) = fmap f xs :> f x
1317
1318 instance Foldable ViewR where
1319 foldMap _ EmptyR = mempty
1320 foldMap f (xs :> x) = foldMap f xs `mappend` f x
1321
1322 foldr _ z EmptyR = z
1323 foldr f z (xs :> x) = foldr f (f x z) xs
1324
1325 foldl _ z EmptyR = z
1326 foldl f z (xs :> x) = foldl f z xs `f` x
1327
1328 foldr1 _ EmptyR = error "foldr1: empty view"
1329 foldr1 f (xs :> x) = foldr f x xs
1330 #if MIN_VERSION_base(4,8,0)
1331 -- The default definitions are sensible for ViewL, but not so much for
1332 -- ViewR.
1333 null EmptyR = True
1334 null (_ :> _) = False
1335
1336 length = foldr' (\_ k -> k+1) 0
1337 #endif
1338
1339 instance Traversable ViewR where
1340 traverse _ EmptyR = pure EmptyR
1341 traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
1342
1343 -- | /O(1)/. Analyse the right end of a sequence.
1344 viewr :: Seq a -> ViewR a
1345 viewr (Seq xs) = case viewRTree xs of
1346 Nothing2 -> EmptyR
1347 Just2 xs' (Elem x) -> Seq xs' :> x
1348
1349 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
1350 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
1351 viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
1352 viewRTree Empty = Nothing2
1353 viewRTree (Single z) = Just2 Empty z
1354 viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z
1355 viewRTree (Deep s pr m (Two y z)) =
1356 Just2 (Deep (s - size z) pr m (One y)) z
1357 viewRTree (Deep s pr m (Three x y z)) =
1358 Just2 (Deep (s - size z) pr m (Two x y)) z
1359 viewRTree (Deep s pr m (Four w x y z)) =
1360 Just2 (Deep (s - size z) pr m (Three w x y)) z
1361
1362 ------------------------------------------------------------------------
1363 -- Scans
1364 --
1365 -- These are not particularly complex applications of the Traversable
1366 -- functor, though making the correspondence with Data.List exact
1367 -- requires the use of (<|) and (|>).
1368 --
1369 -- Note that save for the single (<|) or (|>), we maintain the original
1370 -- structure of the Seq, not having to do any restructuring of our own.
1371 --
1372 -- wasserman.louis@gmail.com, 5/23/09
1373 ------------------------------------------------------------------------
1374
1375 -- | 'scanl' is similar to 'foldl', but returns a sequence of reduced
1376 -- values from the left:
1377 --
1378 -- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
1379 scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
1380 scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
1381
1382 -- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
1383 --
1384 -- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
1385 scanl1 :: (a -> a -> a) -> Seq a -> Seq a
1386 scanl1 f xs = case viewl xs of
1387 EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
1388 x :< xs' -> scanl f x xs'
1389
1390 -- | 'scanr' is the right-to-left dual of 'scanl'.
1391 scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
1392 scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
1393
1394 -- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
1395 scanr1 :: (a -> a -> a) -> Seq a -> Seq a
1396 scanr1 f xs = case viewr xs of
1397 EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
1398 xs' :> x -> scanr f x xs'
1399
1400 -- Indexing
1401
1402 -- | /O(log(min(i,n-i)))/. The element at the specified position,
1403 -- counting from 0. The argument should thus be a non-negative
1404 -- integer less than the size of the sequence.
1405 -- If the position is out of range, 'index' fails with an error.
1406 index :: Seq a -> Int -> a
1407 index (Seq xs) i
1408 | 0 <= i && i < size xs = case lookupTree i xs of
1409 Place _ (Elem x) -> x
1410 | otherwise = error "index out of bounds"
1411
1412 data Place a = Place {-# UNPACK #-} !Int a
1413 #if TESTING
1414 deriving Show
1415 #endif
1416
1417 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
1418 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
1419 lookupTree :: Sized a => Int -> FingerTree a -> Place a
1420 lookupTree _ Empty = error "lookupTree of empty tree"
1421 lookupTree i (Single x) = Place i x
1422 lookupTree i (Deep totalSize pr m sf)
1423 | i < spr = lookupDigit i pr
1424 | i < spm = case lookupTree (i - spr) m of
1425 Place i' xs -> lookupNode i' xs
1426 | otherwise = lookupDigit (i - spm) sf
1427 where
1428 spr = size pr
1429 spm = totalSize - size sf
1430
1431 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
1432 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
1433 lookupNode :: Sized a => Int -> Node a -> Place a
1434 lookupNode i (Node2 _ a b)
1435 | i < sa = Place i a
1436 | otherwise = Place (i - sa) b
1437 where
1438 sa = size a
1439 lookupNode i (Node3 _ a b c)
1440 | i < sa = Place i a
1441 | i < sab = Place (i - sa) b
1442 | otherwise = Place (i - sab) c
1443 where
1444 sa = size a
1445 sab = sa + size b
1446
1447 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
1448 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
1449 lookupDigit :: Sized a => Int -> Digit a -> Place a
1450 lookupDigit i (One a) = Place i a
1451 lookupDigit i (Two a b)
1452 | i < sa = Place i a
1453 | otherwise = Place (i - sa) b
1454 where
1455 sa = size a
1456 lookupDigit i (Three a b c)
1457 | i < sa = Place i a
1458 | i < sab = Place (i - sa) b
1459 | otherwise = Place (i - sab) c
1460 where
1461 sa = size a
1462 sab = sa + size b
1463 lookupDigit i (Four a b c d)
1464 | i < sa = Place i a
1465 | i < sab = Place (i - sa) b
1466 | i < sabc = Place (i - sab) c
1467 | otherwise = Place (i - sabc) d
1468 where
1469 sa = size a
1470 sab = sa + size b
1471 sabc = sab + size c
1472
1473 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position.
1474 -- If the position is out of range, the original sequence is returned.
1475 update :: Int -> a -> Seq a -> Seq a
1476 update i x = adjust (const x) i
1477
1478 -- | /O(log(min(i,n-i)))/. Update the element at the specified position.
1479 -- If the position is out of range, the original sequence is returned.
1480 adjust :: (a -> a) -> Int -> Seq a -> Seq a
1481 adjust f i (Seq xs)
1482 | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
1483 | otherwise = Seq xs
1484
1485 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
1486 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
1487 adjustTree :: Sized a => (Int -> a -> a) ->
1488 Int -> FingerTree a -> FingerTree a
1489 adjustTree _ _ Empty = error "adjustTree of empty tree"
1490 adjustTree f i (Single x) = Single (f i x)
1491 adjustTree f i (Deep s pr m sf)
1492 | i < spr = Deep s (adjustDigit f i pr) m sf
1493 | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
1494 | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
1495 where
1496 spr = size pr
1497 spm = spr + size m
1498
1499 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
1500 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
1501 adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
1502 adjustNode f i (Node2 s a b)
1503 | i < sa = Node2 s (f i a) b
1504 | otherwise = Node2 s a (f (i - sa) b)
1505 where
1506 sa = size a
1507 adjustNode f i (Node3 s a b c)
1508 | i < sa = Node3 s (f i a) b c
1509 | i < sab = Node3 s a (f (i - sa) b) c
1510 | otherwise = Node3 s a b (f (i - sab) c)
1511 where
1512 sa = size a
1513 sab = sa + size b
1514
1515 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
1516 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
1517 adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
1518 adjustDigit f i (One a) = One (f i a)
1519 adjustDigit f i (Two a b)
1520 | i < sa = Two (f i a) b
1521 | otherwise = Two a (f (i - sa) b)
1522 where
1523 sa = size a
1524 adjustDigit f i (Three a b c)
1525 | i < sa = Three (f i a) b c
1526 | i < sab = Three a (f (i - sa) b) c
1527 | otherwise = Three a b (f (i - sab) c)
1528 where
1529 sa = size a
1530 sab = sa + size b
1531 adjustDigit f i (Four a b c d)
1532 | i < sa = Four (f i a) b c d
1533 | i < sab = Four a (f (i - sa) b) c d
1534 | i < sabc = Four a b (f (i - sab) c) d
1535 | otherwise = Four a b c (f (i- sabc) d)
1536 where
1537 sa = size a
1538 sab = sa + size b
1539 sabc = sab + size c
1540
1541 -- | /O(n)/. A generalization of 'fmap', 'mapWithIndex' takes a mapping
1542 -- function that also depends on the element's index, and applies it to every
1543 -- element in the sequence.
1544 mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
1545 mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'
1546 where
1547 {-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}
1548 {-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}
1549 mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b
1550 mapWithIndexTree _ s Empty = s `seq` Empty
1551 mapWithIndexTree f s (Single xs) = Single $ f s xs
1552 mapWithIndexTree f s (Deep n pr m sf) = sPspr `seq` sPsprm `seq`
1553 Deep n
1554 (mapWithIndexDigit f s pr)
1555 (mapWithIndexTree (mapWithIndexNode f) sPspr m)
1556 (mapWithIndexDigit f sPsprm sf)
1557 where
1558 sPspr = s + size pr
1559 sPsprm = s + n - size sf
1560
1561 {-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}
1562 {-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}
1563 mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b
1564 mapWithIndexDigit f s (One a) = One (f s a)
1565 mapWithIndexDigit f s (Two a b) = sPsa `seq` Two (f s a) (f sPsa b)
1566 where
1567 sPsa = s + size a
1568 mapWithIndexDigit f s (Three a b c) = sPsa `seq` sPsab `seq`
1569 Three (f s a) (f sPsa b) (f sPsab c)
1570 where
1571 sPsa = s + size a
1572 sPsab = sPsa + size b
1573 mapWithIndexDigit f s (Four a b c d) = sPsa `seq` sPsab `seq` sPsabc `seq`
1574 Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)
1575 where
1576 sPsa = s + size a
1577 sPsab = sPsa + size b
1578 sPsabc = sPsab + size c
1579
1580 {-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}
1581 {-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}
1582 mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b
1583 mapWithIndexNode f s (Node2 ns a b) = sPsa `seq` Node2 ns (f s a) (f sPsa b)
1584 where
1585 sPsa = s + size a
1586 mapWithIndexNode f s (Node3 ns a b c) = sPsa `seq` sPsab `seq`
1587 Node3 ns (f s a) (f sPsa b) (f sPsab c)
1588 where
1589 sPsa = s + size a
1590 sPsab = sPsa + size b
1591
1592 #ifdef __GLASGOW_HASKELL__
1593 {-# NOINLINE [1] mapWithIndex #-}
1594 {-# RULES
1595 "mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =
1596 mapWithIndex (\k a -> f k (g k a)) xs
1597 "mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =
1598 mapWithIndex (\k a -> f k (g a)) xs
1599 "fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =
1600 mapWithIndex (\k a -> f (g k a)) xs
1601 #-}
1602 #endif
1603
1604 -- | /O(n)/. Convert a given sequence length and a function representing that
1605 -- sequence into a sequence.
1606 fromFunction :: Int -> (Int -> a) -> Seq a
1607 fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"
1608 | len == 0 = empty
1609 | otherwise = Seq $ create (lift_elem f) 1 0 len
1610 where
1611 create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a
1612 create b{-tree_builder-} s{-tree_size-} i{-start_index-} trees = i `seq` s `seq` case trees of
1613 1 -> Single $ b i
1614 2 -> Deep (2*s) (One (b i)) Empty (One (b (i+s)))
1615 3 -> Deep (3*s) (createTwo i) Empty (One (b (i+2*s)))
1616 4 -> Deep (4*s) (createTwo i) Empty (createTwo (i+2*s))
1617 5 -> Deep (5*s) (createThree i) Empty (createTwo (i+3*s))
1618 6 -> Deep (6*s) (createThree i) Empty (createThree (i+3*s))
1619 _ -> case trees `quotRem` 3 of
1620 (trees', 1) -> Deep (trees*s) (createTwo i)
1621 (create mb (3*s) (i+2*s) (trees'-1))
1622 (createTwo (i+(2+3*(trees'-1))*s))
1623 (trees', 2) -> Deep (trees*s) (createThree i)
1624 (create mb (3*s) (i+3*s) (trees'-1))
1625 (createTwo (i+(3+3*(trees'-1))*s))
1626 (trees', _) -> Deep (trees*s) (createThree i)
1627 (create mb (3*s) (i+3*s) (trees'-2))
1628 (createThree (i+(3+3*(trees'-2))*s))
1629 where
1630 createTwo j = Two (b j) (b (j + s))
1631 {-# INLINE createTwo #-}
1632 createThree j = Three (b j) (b (j + s)) (b (j + 2*s))
1633 {-# INLINE createThree #-}
1634 mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))
1635 {-# INLINE mb #-}
1636
1637 lift_elem :: (Int -> a) -> (Int -> Elem a)
1638 #if __GLASGOW_HASKELL__ >= 708
1639 lift_elem g = coerce g
1640 #else
1641 lift_elem g = Elem . g
1642 #endif
1643 {-# INLINE lift_elem #-}
1644
1645 -- | /O(n)/. Create a sequence consisting of the elements of an 'Array'.
1646 -- Note that the resulting sequence elements may be evaluated lazily (as on GHC),
1647 -- so you must force the entire structure to be sure that the original array
1648 -- can be garbage-collected.
1649 fromArray :: Ix i => Array i a -> Seq a
1650 #ifdef __GLASGOW_HASKELL__
1651 fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)
1652 #else
1653 fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)
1654 #endif
1655
1656 -- Splitting
1657
1658 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
1659 -- If @i@ is negative, @'take' i s@ yields the empty sequence.
1660 -- If the sequence contains fewer than @i@ elements, the whole sequence
1661 -- is returned.
1662 take :: Int -> Seq a -> Seq a
1663 take i = fst . splitAt' i
1664
1665 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
1666 -- If @i@ is negative, @'drop' i s@ yields the whole sequence.
1667 -- If the sequence contains fewer than @i@ elements, the empty sequence
1668 -- is returned.
1669 drop :: Int -> Seq a -> Seq a
1670 drop i = snd . splitAt' i
1671
1672 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
1673 -- @'splitAt' i s = ('take' i s, 'drop' i s)@.
1674 splitAt :: Int -> Seq a -> (Seq a, Seq a)
1675 splitAt i (Seq xs) = (Seq l, Seq r)
1676 where (l, r) = split i xs
1677
1678 -- | /O(log(min(i,n-i))) A strict version of 'splitAt'.
1679 splitAt' :: Int -> Seq a -> (Seq a, Seq a)
1680 splitAt' i (Seq xs) = case split i xs of
1681 (l, r) -> (Seq l, Seq r)
1682
1683 split :: Int -> FingerTree (Elem a) ->
1684 (FingerTree (Elem a), FingerTree (Elem a))
1685 split i Empty = i `seq` (Empty, Empty)
1686 split i xs
1687 | size xs > i = case splitTree i xs of
1688 Split l x r -> (l, consTree x r)
1689 | otherwise = (xs, Empty)
1690
1691 data Split t a = Split t a t
1692 #if TESTING
1693 deriving Show
1694 #endif
1695
1696 {-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
1697 {-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
1698 splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
1699 splitTree _ Empty = error "splitTree of empty tree"
1700 splitTree i (Single x) = i `seq` Split Empty x Empty
1701 splitTree i (Deep _ pr m sf)
1702 | i < spr = case splitDigit i pr of
1703 Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
1704 | i < spm = case splitTree im m of
1705 Split ml xs mr -> case splitNode (im - size ml) xs of
1706 Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
1707 | otherwise = case splitDigit (i - spm) sf of
1708 Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
1709 where
1710 spr = size pr
1711 spm = spr + size m
1712 im = i - spr
1713
1714 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1715 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1716 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
1717 splitNode i (Node2 _ a b)
1718 | i < sa = Split Nothing a (Just (One b))
1719 | otherwise = Split (Just (One a)) b Nothing
1720 where
1721 sa = size a
1722 splitNode i (Node3 _ a b c)
1723 | i < sa = Split Nothing a (Just (Two b c))
1724 | i < sab = Split (Just (One a)) b (Just (One c))
1725 | otherwise = Split (Just (Two a b)) c Nothing
1726 where
1727 sa = size a
1728 sab = sa + size b
1729
1730 {-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1731 {-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1732 splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
1733 splitDigit i (One a) = i `seq` Split Nothing a Nothing
1734 splitDigit i (Two a b)
1735 | i < sa = Split Nothing a (Just (One b))
1736 | otherwise = Split (Just (One a)) b Nothing
1737 where
1738 sa = size a
1739 splitDigit i (Three a b c)
1740 | i < sa = Split Nothing a (Just (Two b c))
1741 | i < sab = Split (Just (One a)) b (Just (One c))
1742 | otherwise = Split (Just (Two a b)) c Nothing
1743 where
1744 sa = size a
1745 sab = sa + size b
1746 splitDigit i (Four a b c d)
1747 | i < sa = Split Nothing a (Just (Three b c d))
1748 | i < sab = Split (Just (One a)) b (Just (Two c d))
1749 | i < sabc = Split (Just (Two a b)) c (Just (One d))
1750 | otherwise = Split (Just (Three a b c)) d Nothing
1751 where
1752 sa = size a
1753 sab = sa + size b
1754 sabc = sab + size c
1755
1756 -- | /O(n)/. Returns a sequence of all suffixes of this sequence,
1757 -- longest first. For example,
1758 --
1759 -- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
1760 --
1761 -- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating
1762 -- every suffix in the sequence takes /O(n)/ due to sharing.
1763 tails :: Seq a -> Seq (Seq a)
1764 tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
1765
1766 -- | /O(n)/. Returns a sequence of all prefixes of this sequence,
1767 -- shortest first. For example,
1768 --
1769 -- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
1770 --
1771 -- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating
1772 -- every prefix in the sequence takes /O(n)/ due to sharing.
1773 inits :: Seq a -> Seq (Seq a)
1774 inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
1775
1776 -- This implementation of tails (and, analogously, inits) has the
1777 -- following algorithmic advantages:
1778 -- Evaluating each tail in the sequence takes linear total time,
1779 -- which is better than we could say for
1780 -- @fromList [drop n xs | n <- [0..length xs]]@.
1781 -- Evaluating any individual tail takes logarithmic time, which is
1782 -- better than we can say for either
1783 -- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
1784 --
1785 -- Moreover, if we actually look at every tail in the sequence, the
1786 -- following benchmarks demonstrate that this implementation is modestly
1787 -- faster than any of the above:
1788 --
1789 -- Times (ms)
1790 -- min mean +/-sd median max
1791 -- Seq.tails: 21.986 24.961 10.169 22.417 86.485
1792 -- scanr: 85.392 87.942 2.488 87.425 100.217
1793 -- iterateN: 29.952 31.245 1.574 30.412 37.268
1794 --
1795 -- The algorithm for tails (and, analogously, inits) is as follows:
1796 --
1797 -- A Node in the FingerTree of tails is constructed by evaluating the
1798 -- corresponding tail of the FingerTree of Nodes, considering the first
1799 -- Node in this tail, and constructing a Node in which each tail of this
1800 -- Node is made to be the prefix of the remaining tree. This ends up
1801 -- working quite elegantly, as the remainder of the tail of the FingerTree
1802 -- of Nodes becomes the middle of a new tail, the suffix of the Node is
1803 -- the prefix, and the suffix of the original tree is retained.
1804 --
1805 -- In particular, evaluating the /i/th tail involves making as
1806 -- many partial evaluations as the Node depth of the /i/th element.
1807 -- In addition, when we evaluate the /i/th tail, and we also evaluate
1808 -- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,
1809 -- each of those /m/ evaluations are shared between the computation of
1810 -- the /i/th and /j/th tails.
1811 --
1812 -- wasserman.louis@gmail.com, 7/16/09
1813
1814 tailsDigit :: Digit a -> Digit (Digit a)
1815 tailsDigit (One a) = One (One a)
1816 tailsDigit (Two a b) = Two (Two a b) (One b)
1817 tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
1818 tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
1819
1820 initsDigit :: Digit a -> Digit (Digit a)
1821 initsDigit (One a) = One (One a)
1822 initsDigit (Two a b) = Two (One a) (Two a b)
1823 initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
1824 initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
1825
1826 tailsNode :: Node a -> Node (Digit a)
1827 tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
1828 tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
1829
1830 initsNode :: Node a -> Node (Digit a)
1831 initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
1832 initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
1833
1834 {-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1835 {-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1836 -- | Given a function to apply to tails of a tree, applies that function
1837 -- to every tail of the specified tree.
1838 tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1839 tailsTree _ Empty = Empty
1840 tailsTree f (Single x) = Single (f (Single x))
1841 tailsTree f (Deep n pr m sf) =
1842 Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
1843 (tailsTree f' m)
1844 (fmap (f . digitToTree) (tailsDigit sf))
1845 where
1846 f' ms = let Just2 node m' = viewLTree ms in
1847 fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
1848
1849 {-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1850 {-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1851 -- | Given a function to apply to inits of a tree, applies that function
1852 -- to every init of the specified tree.
1853 initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1854 initsTree _ Empty = Empty
1855 initsTree f (Single x) = Single (f (Single x))
1856 initsTree f (Deep n pr m sf) =
1857 Deep n (fmap (f . digitToTree) (initsDigit pr))
1858 (initsTree f' m)
1859 (fmap (f . deep pr m) (initsDigit sf))
1860 where
1861 f' ms = let Just2 m' node = viewRTree ms in
1862 fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
1863
1864 {-# INLINE foldlWithIndex #-}
1865 -- | 'foldlWithIndex' is a version of 'foldl' that also provides access
1866 -- to the index of each element.
1867 foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
1868 foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)
1869
1870 {-# INLINE foldrWithIndex #-}
1871 -- | 'foldrWithIndex' is a version of 'foldr' that also provides access
1872 -- to the index of each element.
1873 foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
1874 foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0
1875
1876 {-# INLINE listToMaybe' #-}
1877 -- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.
1878 listToMaybe' :: [a] -> Maybe a
1879 listToMaybe' = foldr (\ x _ -> Just x) Nothing
1880
1881 -- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied
1882 -- to a predicate @p@ and a sequence @xs@, returns the longest prefix
1883 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1884 takeWhileL :: (a -> Bool) -> Seq a -> Seq a
1885 takeWhileL p = fst . spanl p
1886
1887 -- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied
1888 -- to a predicate @p@ and a sequence @xs@, returns the longest suffix
1889 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1890 --
1891 -- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.
1892 takeWhileR :: (a -> Bool) -> Seq a -> Seq a
1893 takeWhileR p = fst . spanr p
1894
1895 -- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns
1896 -- the suffix remaining after @'takeWhileL' p xs@.
1897 dropWhileL :: (a -> Bool) -> Seq a -> Seq a
1898 dropWhileL p = snd . spanl p
1899
1900 -- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns
1901 -- the prefix remaining after @'takeWhileR' p xs@.
1902 --
1903 -- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.
1904 dropWhileR :: (a -> Bool) -> Seq a -> Seq a
1905 dropWhileR p = snd . spanr p
1906
1907 -- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to
1908 -- a predicate @p@ and a sequence @xs@, returns a pair whose first
1909 -- element is the longest prefix (possibly empty) of @xs@ of elements that
1910 -- satisfy @p@ and the second element is the remainder of the sequence.
1911 spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1912 spanl p = breakl (not . p)
1913
1914 -- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a
1915 -- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element
1916 -- is the longest /suffix/ (possibly empty) of @xs@ of elements that
1917 -- satisfy @p@ and the second element is the remainder of the sequence.
1918 spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1919 spanr p = breakr (not . p)
1920
1921 {-# INLINE breakl #-}
1922 -- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a
1923 -- predicate @p@ and a sequence @xs@, returns a pair whose first element
1924 -- is the longest prefix (possibly empty) of @xs@ of elements that
1925 -- /do not satisfy/ @p@ and the second element is the remainder of
1926 -- the sequence.
1927 --
1928 -- @'breakl' p@ is equivalent to @'spanl' (not . p)@.
1929 breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1930 breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
1931
1932 {-# INLINE breakr #-}
1933 -- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.
1934 breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1935 breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
1936 where flipPair (x, y) = (y, x)
1937
1938 -- | /O(n)/. The 'partition' function takes a predicate @p@ and a
1939 -- sequence @xs@ and returns sequences of those elements which do and
1940 -- do not satisfy the predicate.
1941 partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1942 partition p = foldl part (empty, empty)
1943 where
1944 part (xs, ys) x
1945 | p x = (xs |> x, ys)
1946 | otherwise = (xs, ys |> x)
1947
1948 -- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence
1949 -- @xs@ and returns a sequence of those elements which satisfy the
1950 -- predicate.
1951 filter :: (a -> Bool) -> Seq a -> Seq a
1952 filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty
1953
1954 -- Indexing sequences
1955
1956 -- | 'elemIndexL' finds the leftmost index of the specified element,
1957 -- if it is present, and otherwise 'Nothing'.
1958 elemIndexL :: Eq a => a -> Seq a -> Maybe Int
1959 elemIndexL x = findIndexL (x ==)
1960
1961 -- | 'elemIndexR' finds the rightmost index of the specified element,
1962 -- if it is present, and otherwise 'Nothing'.
1963 elemIndexR :: Eq a => a -> Seq a -> Maybe Int
1964 elemIndexR x = findIndexR (x ==)
1965
1966 -- | 'elemIndicesL' finds the indices of the specified element, from
1967 -- left to right (i.e. in ascending order).
1968 elemIndicesL :: Eq a => a -> Seq a -> [Int]
1969 elemIndicesL x = findIndicesL (x ==)
1970
1971 -- | 'elemIndicesR' finds the indices of the specified element, from
1972 -- right to left (i.e. in descending order).
1973 elemIndicesR :: Eq a => a -> Seq a -> [Int]
1974 elemIndicesR x = findIndicesR (x ==)
1975
1976 -- | @'findIndexL' p xs@ finds the index of the leftmost element that
1977 -- satisfies @p@, if any exist.
1978 findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
1979 findIndexL p = listToMaybe' . findIndicesL p
1980
1981 -- | @'findIndexR' p xs@ finds the index of the rightmost element that
1982 -- satisfies @p@, if any exist.
1983 findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
1984 findIndexR p = listToMaybe' . findIndicesR p
1985
1986 {-# INLINE findIndicesL #-}
1987 -- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,
1988 -- in ascending order.
1989 findIndicesL :: (a -> Bool) -> Seq a -> [Int]
1990 #if __GLASGOW_HASKELL__
1991 findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
1992 foldrWithIndex g n xs)
1993 #else
1994 findIndicesL p xs = foldrWithIndex g [] xs
1995 where g i x is = if p x then i:is else is
1996 #endif
1997
1998 {-# INLINE findIndicesR #-}
1999 -- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,
2000 -- in descending order.
2001 findIndicesR :: (a -> Bool) -> Seq a -> [Int]
2002 #if __GLASGOW_HASKELL__
2003 findIndicesR p xs = build (\ c n ->
2004 let g z i x = if p x then c i z else z in foldlWithIndex g n xs)
2005 #else
2006 findIndicesR p xs = foldlWithIndex g [] xs
2007 where g is i x = if p x then i:is else is
2008 #endif
2009
2010 ------------------------------------------------------------------------
2011 -- Lists
2012 ------------------------------------------------------------------------
2013
2014 -- The implementation below, by Ross Paterson, avoids the rebuilding
2015 -- the previous (|>)-based implementation suffered from.
2016
2017 -- | /O(n)/. Create a sequence from a finite list of elements.
2018 -- There is a function 'toList' in the opposite direction for all
2019 -- instances of the 'Foldable' class, including 'Seq'.
2020 fromList :: [a] -> Seq a
2021 fromList = Seq . mkTree 1 . map_elem
2022 where
2023 {-# SPECIALIZE mkTree :: Int -> [Elem a] -> FingerTree (Elem a) #-}
2024 {-# SPECIALIZE mkTree :: Int -> [Node a] -> FingerTree (Node a) #-}
2025 mkTree :: (Sized a) => Int -> [a] -> FingerTree a
2026 STRICT_1_OF_2(mkTree)
2027 mkTree _ [] = Empty
2028 mkTree _ [x1] = Single x1
2029 mkTree s [x1, x2] = Deep (2*s) (One x1) Empty (One x2)
2030 mkTree s [x1, x2, x3] = Deep (3*s) (One x1) Empty (Two x2 x3)
2031 mkTree s (x1:x2:x3:x4:xs) = case getNodes (3*s) x4 xs of
2032 (ns, sf) -> case mkTree (3*s) ns of
2033 m -> m `seq` Deep (3*size x1 + size m + size sf) (Three x1 x2 x3) m sf
2034
2035 getNodes :: Int -> a -> [a] -> ([Node a], Digit a)
2036 STRICT_1_OF_3(getNodes)
2037 getNodes _ x1 [] = ([], One x1)
2038 getNodes _ x1 [x2] = ([], Two x1 x2)
2039 getNodes _ x1 [x2, x3] = ([], Three x1 x2 x3)
2040 getNodes s x1 (x2:x3:x4:xs) = (Node3 s x1 x2 x3:ns, d)
2041 where (ns, d) = getNodes s x4 xs
2042
2043 map_elem :: [a] -> [Elem a]
2044 #if __GLASGOW_HASKELL__ >= 708
2045 map_elem xs = coerce xs
2046 #else
2047 map_elem xs = Data.List.map Elem xs
2048 #endif
2049 {-# INLINE map_elem #-}
2050
2051 #if __GLASGOW_HASKELL__ >= 708
2052 instance GHC.Exts.IsList (Seq a) where
2053 type Item (Seq a) = a
2054 fromList = fromList
2055 fromListN = fromList2
2056 toList = toList
2057 #endif
2058
2059 ------------------------------------------------------------------------
2060 -- Reverse
2061 ------------------------------------------------------------------------
2062
2063 -- | /O(n)/. The reverse of a sequence.
2064 reverse :: Seq a -> Seq a
2065 reverse (Seq xs) = Seq (reverseTree id xs)
2066
2067 reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
2068 reverseTree _ Empty = Empty
2069 reverseTree f (Single x) = Single (f x)
2070 reverseTree f (Deep s pr m sf) =
2071 Deep s (reverseDigit f sf)
2072 (reverseTree (reverseNode f) m)
2073 (reverseDigit f pr)
2074
2075 {-# INLINE reverseDigit #-}
2076 reverseDigit :: (a -> a) -> Digit a -> Digit a
2077 reverseDigit f (One a) = One (f a)
2078 reverseDigit f (Two a b) = Two (f b) (f a)
2079 reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
2080 reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
2081
2082 reverseNode :: (a -> a) -> Node a -> Node a
2083 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
2084 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
2085
2086 ------------------------------------------------------------------------
2087 -- Mapping with a splittable value
2088 ------------------------------------------------------------------------
2089
2090 -- For zipping, it is useful to build a result by
2091 -- traversing a sequence while splitting up something else. For zipping, we
2092 -- traverse the first sequence while splitting up the second.
2093 --
2094 -- What makes all this crazy code a good idea:
2095 --
2096 -- Suppose we zip together two sequences of the same length:
2097 --
2098 -- zs = zip xs ys
2099 --
2100 -- We want to get reasonably fast indexing into zs immediately, rather than
2101 -- needing to construct the entire thing first, as the previous implementation
2102 -- required. The first aspect is that we build the result "outside-in" or
2103 -- "top-down", rather than left to right. That gives us access to both ends
2104 -- quickly. But that's not enough, by itself, to give immediate access to the
2105 -- center of zs. For that, we need to be able to skip over larger segments of
2106 -- zs, delaying their construction until we actually need them. The way we do
2107 -- this is to traverse xs, while splitting up ys according to the structure of
2108 -- xs. If we have a Deep _ pr m sf, we split ys into three pieces, and hand off
2109 -- one piece to the prefix, one to the middle, and one to the suffix of the
2110 -- result. The key point is that we don't need to actually do anything further
2111 -- with those pieces until we actually need them; the computations to split
2112 -- them up further and zip them with their matching pieces can be delayed until
2113 -- they're actually needed. We do the same thing for Digits (splitting into
2114 -- between one and four pieces) and Nodes (splitting into two or three). The
2115 -- ultimate result is that we can index into, or split at, any location in zs
2116 -- in polylogarithmic time *immediately*, while still being able to force all
2117 -- the thunks in O(n) time.
2118 --
2119 -- Benchmark info, and alternatives:
2120 --
2121 -- The old zipping code used mapAccumL to traverse the first sequence while
2122 -- cutting down the second sequence one piece at a time.
2123 --
2124 -- An alternative way to express that basic idea is to convert both sequences
2125 -- to lists, zip the lists, and then convert the result back to a sequence.
2126 -- I'll call this the "listy" implementation.
2127 --
2128 -- I benchmarked two operations: Each started by zipping two sequences
2129 -- constructed with replicate and/or fromList. The first would then immediately
2130 -- index into the result. The second would apply deepseq to force the entire
2131 -- result. The new implementation worked much better than either of the others
2132 -- on the immediate indexing test, as expected. It also worked better than the
2133 -- old implementation for all the deepseq tests. For short sequences, the listy
2134 -- implementation outperformed all the others on the deepseq test. However, the
2135 -- splitting implementation caught up and surpassed it once the sequences grew
2136 -- long enough. It seems likely that by avoiding rebuilding, it interacts
2137 -- better with the cache hierarchy.
2138 --
2139 -- David Feuer, with excellent guidance from Carter Schonwald, December 2014
2140
2141 -- | /O(n)/. Constructs a new sequence with the same structure as an existing
2142 -- sequence using a user-supplied mapping function along with a splittable
2143 -- value and a way to split it. The value is split up lazily according to the
2144 -- structure of the sequence, so one piece of the value is distributed to each
2145 -- element of the sequence. The caller should provide a splitter function that
2146 -- takes a number, @n@, and a splittable value, breaks off a chunk of size @n@
2147 -- from the value, and returns that chunk and the remainder as a pair. The
2148 -- following examples will hopefully make the usage clear:
2149 --
2150 -- > zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
2151 -- > zipWith f s1 s2 = splitMap splitAt (\b a -> f a (b `index` 0)) s2' s1'
2152 -- > where
2153 -- > minLen = min (length s1) (length s2)
2154 -- > s1' = take minLen s1
2155 -- > s2' = take minLen s2
2156 --
2157 -- > mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
2158 -- > mapWithIndex f = splitMap (\n i -> (i, n+i)) f 0
2159 splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b
2160 splitMap splt' = go
2161 where
2162 go f s (Seq xs) = Seq $ splitMapTree splt' (\s' (Elem a) -> Elem (f s' a)) s xs
2163
2164 {-# SPECIALIZE splitMapTree :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b #-}
2165 {-# SPECIALIZE splitMapTree :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> FingerTree (Node y) -> FingerTree b #-}
2166 splitMapTree :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> FingerTree a -> FingerTree b
2167 splitMapTree _ _ _ Empty = Empty
2168 splitMapTree _ f s (Single xs) = Single $ f s xs
2169 splitMapTree splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTree splt (splitMapNode splt f) ms m) (splitMapDigit splt f sfs sf)
2170 where
2171 (prs, r) = splt (size pr) s
2172 (ms, sfs) = splt (n - size pr - size sf) r
2173
2174 {-# SPECIALIZE splitMapDigit :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> Digit (Elem y) -> Digit b #-}
2175 {-# SPECIALIZE splitMapDigit :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> Digit (Node y) -> Digit b #-}
2176 splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b
2177 splitMapDigit _ f s (One a) = One (f s a)
2178 splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)
2179 where
2180 (first, second) = splt (size a) s
2181 splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)
2182 where
2183 (first, r) = splt (size a) s
2184 (second, third) = splt (size b) r
2185 splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)
2186 where
2187 (first, s') = splt (size a) s
2188 (middle, fourth) = splt (size b + size c) s'
2189 (second, third) = splt (size b) middle
2190
2191 {-# SPECIALIZE splitMapNode :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> Node (Elem y) -> Node b #-}
2192 {-# SPECIALIZE splitMapNode :: (Int -> s -> (s,s)) -> (s -> Node y -> b) -> s -> Node (Node y) -> Node b #-}
2193 splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b
2194 splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)
2195 where
2196 (first, second) = splt (size a) s
2197 splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)
2198 where
2199 (first, r) = splt (size a) s
2200 (second, third) = splt (size b) r
2201
2202 {-# INLINE splitMap #-}
2203
2204 getSingleton :: Seq a -> a
2205 getSingleton (Seq (Single (Elem a))) = a
2206 getSingleton (Seq Empty) = error "getSingleton: Empty"
2207 getSingleton _ = error "getSingleton: Not a singleton."
2208
2209 ------------------------------------------------------------------------
2210 -- Zipping
2211 ------------------------------------------------------------------------
2212
2213 -- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence
2214 -- of corresponding pairs. If one input is short, excess elements are
2215 -- discarded from the right end of the longer sequence.
2216 zip :: Seq a -> Seq b -> Seq (a, b)
2217 zip = zipWith (,)
2218
2219 -- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the
2220 -- function given as the first argument, instead of a tupling function.
2221 -- For example, @zipWith (+)@ is applied to two sequences to take the
2222 -- sequence of corresponding sums.
2223 zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
2224 zipWith f s1 s2 = zipWith' f s1' s2'
2225 where
2226 minLen = min (length s1) (length s2)
2227 s1' = take minLen s1
2228 s2' = take minLen s2
2229
2230 -- | A version of zipWith that assumes the sequences have the same length.
2231 zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
2232 zipWith' f s1 s2 = splitMap splitAt' (\s a -> f a (getSingleton s)) s2 s1
2233
2234 -- | /O(min(n1,n2,n3))/. 'zip3' takes three sequences and returns a
2235 -- sequence of triples, analogous to 'zip'.
2236 zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
2237 zip3 = zipWith3 (,,)
2238
2239 -- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines
2240 -- three elements, as well as three sequences and returns a sequence of
2241 -- their point-wise combinations, analogous to 'zipWith'.
2242 zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
2243 zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'
2244 where
2245 minLen = minimum [length s1, length s2, length s3]
2246 s1' = take minLen s1
2247 s2' = take minLen s2
2248 s3' = take minLen s3
2249
2250 zipWith3' :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
2251 zipWith3' f s1 s2 s3 = zipWith' ($) (zipWith' f s1 s2) s3
2252
2253 -- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a
2254 -- sequence of quadruples, analogous to 'zip'.
2255 zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
2256 zip4 = zipWith4 (,,,)
2257
2258 -- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines
2259 -- four elements, as well as four sequences and returns a sequence of
2260 -- their point-wise combinations, analogous to 'zipWith'.
2261 zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
2262 zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'
2263 where
2264 minLen = minimum [length s1, length s2, length s3, length s4]
2265 s1' = take minLen s1
2266 s2' = take minLen s2
2267 s3' = take minLen s3
2268 s4' = take minLen s4
2269
2270 ------------------------------------------------------------------------
2271 -- Sorting
2272 --
2273 -- sort and sortBy are implemented by simple deforestations of
2274 -- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList
2275 -- which does not get deforested automatically, it would appear.
2276 --
2277 -- Unstable sorting is performed by a heap sort implementation based on
2278 -- pairing heaps. Because the internal structure of sequences is quite
2279 -- varied, it is difficult to get blocks of elements of roughly the same
2280 -- length, which would improve merge sort performance. Pairing heaps,
2281 -- on the other hand, are relatively resistant to the effects of merging
2282 -- heaps of wildly different sizes, as guaranteed by its amortized
2283 -- constant-time merge operation. Moreover, extensive use of SpecConstr
2284 -- transformations can be done on pairing heaps, especially when we're
2285 -- only constructing them to immediately be unrolled.
2286 --
2287 -- On purely random sequences of length 50000, with no RTS options,
2288 -- I get the following statistics, in which heapsort is about 42.5%
2289 -- faster: (all comparisons done with -O2)
2290 --
2291 -- Times (ms) min mean +/-sd median max
2292 -- to/from list: 103.802 108.572 7.487 106.436 143.339
2293 -- unstable heapsort: 60.686 62.968 4.275 61.187 79.151
2294 --
2295 -- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
2296 -- The gap is narrowed when more memory is available, but heapsort still
2297 -- wins, 15% faster, with +RTS -H128m:
2298 --
2299 -- Times (ms) min mean +/-sd median max
2300 -- to/from list: 42.692 45.074 2.596 44.600 56.601
2301 -- unstable heapsort: 37.100 38.344 3.043 37.715 55.526
2302 --
2303 -- In addition, on strictly increasing sequences the gap is even wider
2304 -- than normal; heapsort is 68.5% faster with no RTS options:
2305 -- Times (ms) min mean +/-sd median max
2306 -- to/from list: 52.236 53.574 1.987 53.034 62.098
2307 -- unstable heapsort: 16.433 16.919 0.931 16.681 21.622
2308 --
2309 -- This may be attributed to the elegant nature of the pairing heap.
2310 --
2311 -- wasserman.louis@gmail.com, 7/20/09
2312 ------------------------------------------------------------------------
2313
2314 -- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural
2315 -- ordering of its elements. The sort is stable.
2316 -- If stability is not required, 'unstableSort' can be considerably
2317 -- faster, and in particular uses less memory.
2318 sort :: Ord a => Seq a -> Seq a
2319 sort = sortBy compare
2320
2321 -- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the
2322 -- specified comparator. The sort is stable.
2323 -- If stability is not required, 'unstableSortBy' can be considerably
2324 -- faster, and in particular uses less memory.
2325 sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
2326 sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
2327
2328 -- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by
2329 -- the natural ordering of its elements, but the sort is not stable.
2330 -- This algorithm is frequently faster and uses less memory than 'sort',
2331 -- and performs extremely well -- frequently twice as fast as 'sort' --
2332 -- when the sequence is already nearly sorted.
2333 unstableSort :: Ord a => Seq a -> Seq a
2334 unstableSort = unstableSortBy compare
2335
2336 -- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'
2337 -- takes an arbitrary comparator and sorts the specified sequence.
2338 -- The sort is not stable. This algorithm is frequently faster and
2339 -- uses less memory than 'sortBy', and performs extremely well --
2340 -- frequently twice as fast as 'sortBy' -- when the sequence is already
2341 -- nearly sorted.
2342 unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
2343 unstableSortBy cmp (Seq xs) =
2344 fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
2345 toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
2346
2347 -- | fromList2, given a list and its length, constructs a completely
2348 -- balanced Seq whose elements are that list using the replicateA
2349 -- generalization.
2350 fromList2 :: Int -> [a] -> Seq a
2351 fromList2 n = execState (replicateA n (State ht))
2352 where
2353 ht (x:xs) = (xs, x)
2354 ht [] = error "fromList2: short list"
2355
2356 -- | A 'PQueue' is a simple pairing heap.
2357 data PQueue e = PQueue e (PQL e)
2358 data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
2359
2360 infixr 8 :&
2361
2362 #if TESTING
2363
2364 instance Functor PQueue where
2365 fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
2366
2367 instance Functor PQL where
2368 fmap f (q :& qs) = fmap f q :& fmap f qs
2369 fmap _ Nil = Nil
2370
2371 instance Show e => Show (PQueue e) where
2372 show = unlines . draw . fmap show
2373
2374 -- borrowed wholesale from Data.Tree, as Data.Tree actually depends
2375 -- on Data.Sequence
2376 draw :: PQueue String -> [String]
2377 draw (PQueue x ts0) = x : drawSubTrees ts0
2378 where
2379 drawSubTrees Nil = []
2380 drawSubTrees (t :& Nil) =
2381 "|" : shift "`- " " " (draw t)
2382 drawSubTrees (t :& ts) =
2383 "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
2384
2385 shift first other = Data.List.zipWith (++) (first : repeat other)
2386 #endif
2387
2388 -- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into
2389 -- a sorted list.
2390 unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
2391 unrollPQ cmp = unrollPQ'
2392 where
2393 {-# INLINE unrollPQ' #-}
2394 unrollPQ' (PQueue x ts) = x:mergePQs0 ts
2395 (<>) = mergePQ cmp
2396 mergePQs0 Nil = []
2397 mergePQs0 (t :& Nil) = unrollPQ' t
2398 mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
2399 mergePQs t ts = t `seq` case ts of
2400 Nil -> unrollPQ' t
2401 t1 :& Nil -> unrollPQ' (t <> t1)
2402 t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'
2403
2404 -- | 'toPQ', given an ordering function and a mechanism for queueifying
2405 -- elements, converts a 'FingerTree' to a 'PQueue'.
2406 toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
2407 toPQ _ _ Empty = Nothing
2408 toPQ _ f (Single x) = Just (f x)
2409 toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))
2410 where
2411 fDigit digit = case fmap f digit of
2412 One a -> a
2413 Two a b -> a <> b
2414 Three a b c -> a <> b <> c
2415 Four a b c d -> (a <> b) <> (c <> d)
2416 (<>) = mergePQ cmp
2417 fNode = fDigit . nodeToDigit
2418 pr' = fDigit pr
2419 sf' = fDigit sf
2420
2421 -- | 'mergePQ' merges two 'PQueue's.
2422 mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
2423 mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
2424 | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)
2425 | otherwise = PQueue x1 (q2 :& ts1)