af06317ff240f8a97f6361f54bac5b27765aac48
[packages/containers.git] / Data / Sequence.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3 #if __GLASGOW_HASKELL__ >= 708
4 #define DEFINE_PATTERN_SYNONYMS 1
5 #endif
6 #if __GLASGOW_HASKELL__
7 {-# LANGUAGE DeriveDataTypeable #-}
8 {-# LANGUAGE StandaloneDeriving #-}
9 {-# LANGUAGE FlexibleInstances #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 #endif
12 #if __GLASGOW_HASKELL__ >= 703
13 {-# LANGUAGE Trustworthy #-}
14 #endif
15 #if __GLASGOW_HASKELL__ >= 708
16 {-# LANGUAGE TypeFamilies #-}
17 #endif
18 #ifdef DEFINE_PATTERN_SYNONYMS
19 {-# LANGUAGE PatternSynonyms #-}
20 {-# LANGUAGE ViewPatterns #-}
21 #endif
22
23 #include "containers.h"
24
25 -----------------------------------------------------------------------------
26 -- |
27 -- Module : Data.Sequence
28 -- Copyright : (c) Ross Paterson 2005
29 -- (c) Louis Wasserman 2009
30 -- (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and
31 -- Milan Straka 2014
32 -- License : BSD-style
33 -- Maintainer : libraries@haskell.org
34 -- Stability : experimental
35 -- Portability : portable
36 --
37 -- General purpose finite sequences.
38 -- Apart from being finite and having strict operations, sequences
39 -- also differ from lists in supporting a wider variety of operations
40 -- efficiently.
41 --
42 -- An amortized running time is given for each operation, with /n/ referring
43 -- to the length of the sequence and /i/ being the integral index used by
44 -- some operations. These bounds hold even in a persistent (shared) setting.
45 --
46 -- The implementation uses 2-3 finger trees annotated with sizes,
47 -- as described in section 4.2 of
48 --
49 -- * Ralf Hinze and Ross Paterson,
50 -- \"Finger trees: a simple general-purpose data structure\",
51 -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
52 -- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>
53 --
54 -- /Note/: Many of these operations have the same names as similar
55 -- operations on lists in the "Prelude". The ambiguity may be resolved
56 -- using either qualification or the @hiding@ clause.
57 --
58 -- /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@. Violation
59 -- of this condition is not detected and if the size limit is exceeded, the
60 -- behaviour of the sequence is undefined. This is unlikely to occur in most
61 -- applications, but some care may be required when using '><', '<*>', '*>', or
62 -- '>>', particularly repeatedly and particularly in combination with
63 -- 'replicate' or 'fromFunction'.
64 --
65 -----------------------------------------------------------------------------
66
67 module Data.Sequence (
68 #if defined(TESTING)
69 Elem(..), FingerTree(..), Node(..), Digit(..),
70 #if __GLASGOW_HASKELL__ >= 800
71 Seq (.., Empty, (:<|), (:|>)),
72 #else
73 Seq (..),
74 #if defined(DEFINE_PATTERN_SYNONYMS)
75 -- * Pattern synonyms
76 pattern Empty, -- :: Seq a
77 pattern (:<|), -- :: a -> Seq a -> Seq a
78 pattern (:|>), -- :: Seq a -> a -> Seq a
79 #endif
80 #endif
81
82 #elif __GLASGOW_HASKELL__ >= 800
83 Seq (Empty, (:<|), (:|>)),
84 #else
85 Seq,
86 #if defined(DEFINE_PATTERN_SYNONYMS)
87 -- * Pattern synonyms
88 pattern Empty, -- :: Seq a
89 pattern (:<|), -- :: a -> Seq a -> Seq a
90 pattern (:|>), -- :: Seq a -> a -> Seq a
91 #endif
92 #endif
93 -- * Construction
94 empty, -- :: Seq a
95 singleton, -- :: a -> Seq a
96 (<|), -- :: a -> Seq a -> Seq a
97 (|>), -- :: Seq a -> a -> Seq a
98 (><), -- :: Seq a -> Seq a -> Seq a
99 fromList, -- :: [a] -> Seq a
100 fromFunction, -- :: Int -> (Int -> a) -> Seq a
101 fromArray, -- :: Ix i => Array i a -> Seq a
102 -- ** Repetition
103 replicate, -- :: Int -> a -> Seq a
104 replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)
105 replicateM, -- :: Monad m => Int -> m a -> m (Seq a)
106 cycleTaking, -- :: Int -> Seq a -> Seq a
107 -- ** Iterative construction
108 iterateN, -- :: Int -> (a -> a) -> a -> Seq a
109 unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a
110 unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
111 -- * Deconstruction
112 -- | Additional functions for deconstructing sequences are available
113 -- via the 'Foldable' instance of 'Seq'.
114
115 -- ** Queries
116 null, -- :: Seq a -> Bool
117 length, -- :: Seq a -> Int
118 -- ** Views
119 ViewL(..),
120 viewl, -- :: Seq a -> ViewL a
121 ViewR(..),
122 viewr, -- :: Seq a -> ViewR a
123 -- * Scans
124 scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a
125 scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a
126 scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b
127 scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a
128 -- * Sublists
129 tails, -- :: Seq a -> Seq (Seq a)
130 inits, -- :: Seq a -> Seq (Seq a)
131 chunksOf, -- :: Int -> Seq a -> Seq (Seq a)
132 -- ** Sequential searches
133 takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
134 takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
135 dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
136 dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
137 spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
138 spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
139 breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
140 breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
141 partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
142 filter, -- :: (a -> Bool) -> Seq a -> Seq a
143 -- * Sorting
144 sort, -- :: Ord a => Seq a -> Seq a
145 sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
146 unstableSort, -- :: Ord a => Seq a -> Seq a
147 unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
148 -- * Indexing
149 lookup, -- :: Int -> Seq a -> Maybe a
150 (!?), -- :: Seq a -> Int -> Maybe a
151 index, -- :: Seq a -> Int -> a
152 adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
153 update, -- :: Int -> a -> Seq a -> Seq a
154 take, -- :: Int -> Seq a -> Seq a
155 drop, -- :: Int -> Seq a -> Seq a
156 insertAt, -- :: Int -> a -> Seq a -> Seq a
157 deleteAt, -- :: Int -> Seq a -> Seq a
158 splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
159 -- ** Indexing with predicates
160 -- | These functions perform sequential searches from the left
161 -- or right ends of the sequence, returning indices of matching
162 -- elements.
163 elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int
164 elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]
165 elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int
166 elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]
167 findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int
168 findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]
169 findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
170 findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
171 -- * Folds
172 -- | General folds are available via the 'Foldable' instance of 'Seq'.
173 foldMapWithIndex, -- :: Monoid m => (Int -> a -> m) -> Seq a -> m
174 foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
175 foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
176 -- * Transformations
177 mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b
178 traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
179 reverse, -- :: Seq a -> Seq a
180 intersperse, -- :: a -> Seq a -> Seq a
181 -- ** Zips
182 zip, -- :: Seq a -> Seq b -> Seq (a, b)
183 zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
184 zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
185 zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
186 zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
187 zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
188 #if TESTING
189 Sized(..),
190 deep,
191 node2,
192 node3,
193 #endif
194 ) where
195
196 import Prelude hiding (
197 Functor(..),
198 #if MIN_VERSION_base(4,8,0)
199 Applicative, (<$>), foldMap, Monoid,
200 #endif
201 null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
202 scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
203 takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
204 import qualified Data.List
205 import Control.Applicative (Applicative(..), (<$>), (<**>), Alternative,
206 WrappedMonad(..), liftA, liftA2, liftA3)
207 import qualified Control.Applicative as Applicative (Alternative(..))
208 import Control.DeepSeq (NFData(rnf))
209 import Control.Monad (MonadPlus(..), ap)
210 import Data.Monoid (Monoid(..))
211 import Data.Functor (Functor(..))
212 import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap), foldl', toList)
213 #if MIN_VERSION_base(4,8,0)
214 import Data.Foldable (foldr')
215 #endif
216 #if MIN_VERSION_base(4,9,0)
217 import qualified Data.Semigroup as Semigroup
218 #endif
219 import Data.Traversable
220 import Data.Typeable
221
222 -- GHC specific stuff
223 #ifdef __GLASGOW_HASKELL__
224 import GHC.Exts (build)
225 import Text.Read (Lexeme(Ident), lexP, parens, prec,
226 readPrec, readListPrec, readListPrecDefault)
227 import Data.Data
228 import Data.String (IsString(..))
229 #endif
230
231 -- Array stuff, with GHC.Arr on GHC
232 import Data.Array (Ix, Array)
233 import qualified Data.Array
234 #ifdef __GLASGOW_HASKELL__
235 import qualified GHC.Arr
236 #endif
237
238 -- Coercion on GHC 7.8+
239 #if __GLASGOW_HASKELL__ >= 708
240 import Data.Coerce
241 import qualified GHC.Exts
242 #else
243 #endif
244
245 -- Identity functor on base 4.8 (GHC 7.10+)
246 #if MIN_VERSION_base(4,8,0)
247 import Data.Functor.Identity (Identity(..))
248 #endif
249
250 #if !MIN_VERSION_base(4,8,0)
251 import Data.Word (Word)
252 #endif
253
254 import Data.Utils.StrictPair (StrictPair (..))
255
256 default ()
257
258 -- We define our own copy here, for Monoid only, even though this
259 -- is now a Semigroup operator in base. The essential reason is that
260 -- we have absolutely no use for semigroups in this module. Everything
261 -- that needs to sum things up requires a Monoid constraint to deal
262 -- with empty sequences. I'm not sure if there's a risk of walking
263 -- through dictionaries to reach <> from Monoid, but I see no reason
264 -- to risk it.
265 infixr 6 <>
266 (<>) :: Monoid m => m -> m -> m
267 (<>) = mappend
268 {-# INLINE (<>) #-}
269
270 infixr 5 `consTree`
271 infixl 5 `snocTree`
272 infixr 5 `appendTree0`
273
274 infixr 5 ><
275 infixr 5 <|, :<
276 infixl 5 |>, :>
277
278 #ifdef DEFINE_PATTERN_SYNONYMS
279 infixr 5 :<|
280 infixl 5 :|>
281
282 -- TODO: Once GHC implements some way to prevent non-exhaustive
283 -- pattern match warnings for pattern synonyms, we should be
284 -- sure to take advantage of that.
285
286 -- Unfortunately, there's some extra noise here because
287 -- pattern synonyms could not have signatures until 7.10,
288 -- but 8.0 at least will warn if they're missing.
289
290 -- | A pattern synonym matching an empty sequence.
291 #if __GLASGOW_HASKELL__ >= 710
292 pattern Empty :: Seq a
293 #else
294 #endif
295 pattern Empty = Seq EmptyT
296
297 -- Non-trivial bidirectional pattern synonyms are only
298 -- available in GHC >= 7.10. In earlier versions, these
299 -- can be used to match, but not to construct.
300
301 -- | A pattern synonym viewing the front of a non-empty
302 -- sequence.
303 #if __GLASGOW_HASKELL__ >= 710
304 pattern (:<|) :: a -> Seq a -> Seq a
305 #endif
306 pattern x :<| xs <- (viewl -> x :< xs)
307 #if __GLASGOW_HASKELL__ >= 710
308 where
309 x :<| xs = x <| xs
310 #endif
311
312 -- | A pattern synonym viewing the rear of a non-empty
313 -- sequence.
314 #if __GLASGOW_HASKELL__ >= 710
315 pattern (:|>) :: Seq a -> a -> Seq a
316 #endif
317 pattern xs :|> x <- (viewr -> xs :> x)
318 #if __GLASGOW_HASKELL__ >= 710
319 where
320 xs :|> x = xs |> x
321 #endif
322 #endif
323
324 class Sized a where
325 size :: a -> Int
326
327 -- In much the same way that Sized lets us handle the
328 -- sizes of elements and nodes uniformly, MaybeForce lets
329 -- us handle their strictness (or lack thereof) uniformly.
330 -- We can `mseq` something and not have to worry about
331 -- whether it's an element or a node.
332 class MaybeForce a where
333 maybeRwhnf :: a -> ()
334
335 mseq :: MaybeForce a => a -> b -> b
336 mseq a b = case maybeRwhnf a of () -> b
337 {-# INLINE mseq #-}
338
339 infixr 0 $!?
340 ($!?) :: MaybeForce a => (a -> b) -> a -> b
341 f $!? a = case maybeRwhnf a of () -> f a
342 {-# INLINE ($!?) #-}
343
344 instance MaybeForce (Elem a) where
345 maybeRwhnf _ = ()
346 {-# INLINE maybeRwhnf #-}
347
348 instance MaybeForce (Node a) where
349 maybeRwhnf !_ = ()
350 {-# INLINE maybeRwhnf #-}
351
352 -- | General-purpose finite sequences.
353 newtype Seq a = Seq (FingerTree (Elem a))
354
355 instance Functor Seq where
356 fmap = fmapSeq
357 #ifdef __GLASGOW_HASKELL__
358 x <$ s = replicate (length s) x
359 #endif
360
361 fmapSeq :: (a -> b) -> Seq a -> Seq b
362 fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
363 #ifdef __GLASGOW_HASKELL__
364 {-# NOINLINE [1] fmapSeq #-}
365 {-# RULES
366 "fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs
367 #-}
368 #endif
369 #if __GLASGOW_HASKELL__ >= 709
370 -- Safe coercions were introduced in 7.8, but did not work well with RULES yet.
371 {-# RULES
372 "fmapSeq/coerce" fmapSeq coerce = coerce
373 #-}
374 #endif
375
376 instance Foldable Seq where
377 foldMap f (Seq xs) = foldMap (foldMap f) xs
378 foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
379 foldl f z (Seq xs) = foldl (foldl f) z xs
380
381 foldr1 f (Seq xs) = getElem (foldr1 f' xs)
382 where f' (Elem x) (Elem y) = Elem (f x y)
383
384 foldl1 f (Seq xs) = getElem (foldl1 f' xs)
385 where f' (Elem x) (Elem y) = Elem (f x y)
386
387 #if MIN_VERSION_base(4,8,0)
388 length = length
389 {-# INLINE length #-}
390 null = null
391 {-# INLINE null #-}
392 #endif
393
394 instance Traversable Seq where
395 traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
396
397 instance NFData a => NFData (Seq a) where
398 rnf (Seq xs) = rnf xs
399
400 instance Monad Seq where
401 return = pure
402 xs >>= f = foldl' add empty xs
403 where add ys x = ys >< f x
404 (>>) = (*>)
405
406 instance Applicative Seq where
407 pure = singleton
408 xs *> ys = cycleNTimes (length xs) ys
409
410 fs <*> xs@(Seq xsFT) = case viewl fs of
411 EmptyL -> empty
412 firstf :< fs' -> case viewr fs' of
413 EmptyR -> fmap firstf xs
414 Seq fs''FT :> lastf -> case rigidify xsFT of
415 RigidEmpty -> empty
416 RigidOne (Elem x) -> fmap ($x) fs
417 RigidTwo (Elem x1) (Elem x2) ->
418 Seq $ ap2FT firstf fs''FT lastf (x1, x2)
419 RigidThree (Elem x1) (Elem x2) (Elem x3) ->
420 Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)
421 RigidFull r@(Rigid s pr _m sf) -> Seq $
422 Deep (s * length fs)
423 (fmap (fmap firstf) (nodeToDigit pr))
424 (aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)
425 (fmap (fmap lastf) (nodeToDigit sf))
426
427
428 ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)
429 ap2FT firstf fs lastf (x,y) =
430 Deep (size fs * 2 + 4)
431 (Two (Elem $ firstf x) (Elem $ firstf y))
432 (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs)
433 (Two (Elem $ lastf x) (Elem $ lastf y))
434
435 ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)
436 ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6)
437 (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))
438 (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs)
439 (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))
440
441
442 data Rigidified a = RigidEmpty
443 | RigidOne a
444 | RigidTwo a a
445 | RigidThree a a a
446 | RigidFull (Rigid a)
447 #ifdef TESTING
448 deriving Show
449 #endif
450
451 -- | A finger tree whose top level has only Two and/or Three digits, and whose
452 -- other levels have only One and Two digits. A Rigid tree is precisely what one
453 -- gets by unzipping/inverting a 2-3 tree, so it is precisely what we need to
454 -- turn a finger tree into in order to transform it into a 2-3 tree.
455 data Rigid a = Rigid {-# UNPACK #-} !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)
456 #ifdef TESTING
457 deriving Show
458 #endif
459
460 -- | A finger tree whose digits are all ones and twos
461 data Thin a = EmptyTh
462 | SingleTh a
463 | DeepTh {-# UNPACK #-} !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)
464 #ifdef TESTING
465 deriving Show
466 #endif
467
468 data Digit12 a = One12 a | Two12 a a
469 #ifdef TESTING
470 deriving Show
471 #endif
472
473 -- | Sometimes, we want to emphasize that we are viewing a node as a top-level
474 -- digit of a 'Rigid' tree.
475 type Digit23 a = Node a
476
477 -- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@. It
478 -- produces the center part of a finger tree, with a prefix corresponding to
479 -- the prefix of @xs@ and a suffix corresponding to the suffix of @xs@ omitted;
480 -- the missing suffix and prefix are added by the caller. For the recursive
481 -- call, it squashes the prefix and the suffix into the center tree. Once it
482 -- gets to the bottom, it turns the tree into a 2-3 tree, applies 'mapMulFT' to
483 -- produce the main body, and glues all the pieces together.
484 --
485 -- 'map23' itself is a bit horrifying because of the nested types involved. Its
486 -- job is to map over the *elements* of a 2-3 tree, rather than the subtrees.
487 -- If we used a higher-order nested type with MPTC, we could probably use a
488 -- class, but as it is we have to build up 'map23' explicitly through the
489 -- recursion.
490 aptyMiddle
491 :: (c -> d)
492 -> (c -> d)
493 -> ((a -> b) -> c -> d)
494 -> FingerTree (Elem (a -> b))
495 -> Rigid c
496 -> FingerTree (Node d)
497
498 -- Not at the bottom yet
499
500 aptyMiddle firstf
501 lastf
502 map23
503 fs
504 (Rigid s pr (DeepTh sm prm mm sfm) sf)
505 = Deep (sm + s * (size fs + 1)) -- note: sm = s - size pr - size sf
506 (fmap (fmap firstf) (digit12ToDigit prm))
507 (aptyMiddle (fmap firstf)
508 (fmap lastf)
509 (fmap . map23)
510 fs
511 (Rigid s (squashL pr prm) mm (squashR sfm sf)))
512 (fmap (fmap lastf) (digit12ToDigit sfm))
513
514 -- At the bottom
515
516 aptyMiddle firstf
517 lastf
518 map23
519 fs
520 (Rigid s pr EmptyTh sf)
521 = deep
522 (One (fmap firstf sf))
523 (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
524 (One (fmap lastf pr))
525 where converted = node2 pr sf
526
527 aptyMiddle firstf
528 lastf
529 map23
530 fs
531 (Rigid s pr (SingleTh q) sf)
532 = deep
533 (Two (fmap firstf q) (fmap firstf sf))
534 (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
535 (Two (fmap lastf pr) (fmap lastf q))
536 where converted = node3 pr q sf
537
538 digit12ToDigit :: Digit12 a -> Digit a
539 digit12ToDigit (One12 a) = One a
540 digit12ToDigit (Two12 a b) = Two a b
541
542 -- Squash the first argument down onto the left side of the second.
543 squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)
544 squashL m (One12 n) = node2 m n
545 squashL m (Two12 n1 n2) = node3 m n1 n2
546
547 -- Squash the second argument down onto the right side of the first
548 squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)
549 squashR (One12 n) m = node2 n m
550 squashR (Two12 n1 n2) m = node3 n1 n2 m
551
552
553 -- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size
554 -- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the
555 -- function is applied to the "leaves" of the 'FingerTree' (i.e., given a
556 -- @FingerTree (Elem a)@, it applies the function to elements of type @Elem
557 -- a@), replacing the leaves with subtrees of at least the same height, e.g.,
558 -- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations
559 -- match up properly.
560 mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b
561 mapMulFT _ _ EmptyT = EmptyT
562 mapMulFT _mul f (Single a) = Single (f a)
563 mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)
564
565 mapMulNode :: Int -> (a -> b) -> Node a -> Node b
566 mapMulNode mul f (Node2 s a b) = Node2 (mul * s) (f a) (f b)
567 mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)
568
569 -- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree'
570 -- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have
571 -- only two and three digits at the top level and only one and two
572 -- digits elsewhere. If the tree has fewer than four elements, 'rigidify'
573 -- will simply extract them, and will not build a tree.
574 rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)
575 -- The patterns below just fix up the top level of the tree; 'rigidify'
576 -- delegates the hard work to 'thin'.
577
578 rigidify EmptyT = RigidEmpty
579
580 rigidify (Single q) = RigidOne q
581
582 -- The left digit is Two or Three
583 rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf
584 rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf
585
586 -- The left digit is Four
587 rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf
588
589 -- The left digit is One
590 rigidify (Deep s (One a) m sf) = case viewLTree m of
591 ConsLTree (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf
592 ConsLTree (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf
593 EmptyLTree -> case sf of
594 One b -> RigidTwo a b
595 Two b c -> RigidThree a b c
596 Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)
597 Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)
598
599 -- | /O(log n)/ (incremental) Takes a tree whose left side has been rigidified
600 -- and finishes the job.
601 rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)
602
603 -- The right digit is Two, Three, or Four
604 rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)
605 rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)
606 rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)
607
608 -- The right digit is One
609 rigidifyRight s pr m (One e) = case viewRTree m of
610 SnocRTree m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)
611 SnocRTree m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)
612 EmptyRTree -> case pr of
613 Node2 _ a b -> RigidThree a b e
614 Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)
615
616 -- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones
617 -- and twos.
618 thin :: Sized a => FingerTree a -> Thin a
619 -- Note that 'thin12' will produce a 'DeepTh' constructor immediately before
620 -- recursively calling 'thin'.
621 thin EmptyT = EmptyTh
622 thin (Single a) = SingleTh a
623 thin (Deep s pr m sf) =
624 case pr of
625 One a -> thin12 s (One12 a) m sf
626 Two a b -> thin12 s (Two12 a b) m sf
627 Three a b c -> thin12 s (One12 a) (node2 b c `consTree` m) sf
628 Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf
629
630 thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a
631 thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)
632 thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)
633 thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)
634 thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d)
635
636 -- | Intersperse an element between the elements of a sequence.
637 -- > intersperse a empty = empty
638 -- > intersperse a (singleton x) = singleton x
639 -- > intersperse a (fromList [x,y]) = fromList [x,a,y]
640 -- > intersperse a (fromList [x,y,z]) = fromList [x,a,y,a,z]
641 --
642 -- @since 0.5.8
643 intersperse :: a -> Seq a -> Seq a
644 intersperse y xs = case viewl xs of
645 EmptyL -> empty
646 p :< ps -> p <| (ps <**> (const y <| singleton id))
647 -- We used to use
648 --
649 -- intersperse y xs = drop 1 $ xs <**> (const y <| singleton id)
650 --
651 -- but if length xs = ((maxBound :: Int) `quot` 2) + 1 then
652 --
653 -- length (xs <**> (const y <| singleton id)) will wrap around to negative
654 -- and the drop won't work. The new implementation can produce a result
655 -- right up to maxBound :: Int
656
657 instance MonadPlus Seq where
658 mzero = empty
659 mplus = (><)
660
661 instance Alternative Seq where
662 empty = empty
663 (<|>) = (><)
664
665 instance Eq a => Eq (Seq a) where
666 xs == ys = length xs == length ys && toList xs == toList ys
667
668 instance Ord a => Ord (Seq a) where
669 compare xs ys = compare (toList xs) (toList ys)
670
671 #if TESTING
672 instance Show a => Show (Seq a) where
673 showsPrec p (Seq x) = showsPrec p x
674 #else
675 instance Show a => Show (Seq a) where
676 showsPrec p xs = showParen (p > 10) $
677 showString "fromList " . shows (toList xs)
678 #endif
679
680 instance Read a => Read (Seq a) where
681 #ifdef __GLASGOW_HASKELL__
682 readPrec = parens $ prec 10 $ do
683 Ident "fromList" <- lexP
684 xs <- readPrec
685 return (fromList xs)
686
687 readListPrec = readListPrecDefault
688 #else
689 readsPrec p = readParen (p > 10) $ \ r -> do
690 ("fromList",s) <- lex r
691 (xs,t) <- reads s
692 return (fromList xs,t)
693 #endif
694
695 instance Monoid (Seq a) where
696 mempty = empty
697 mappend = (><)
698
699 #if MIN_VERSION_base(4,9,0)
700 instance Semigroup.Semigroup (Seq a) where
701 (<>) = (><)
702 #endif
703
704 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
705
706 #if __GLASGOW_HASKELL__
707 instance Data a => Data (Seq a) where
708 gfoldl f z s = case viewl s of
709 EmptyL -> z empty
710 x :< xs -> z (<|) `f` x `f` xs
711
712 gunfold k z c = case constrIndex c of
713 1 -> z empty
714 2 -> k (k (z (<|)))
715 _ -> error "gunfold"
716
717 toConstr xs
718 | null xs = emptyConstr
719 | otherwise = consConstr
720
721 dataTypeOf _ = seqDataType
722
723 dataCast1 f = gcast1 f
724
725 emptyConstr, consConstr :: Constr
726 emptyConstr = mkConstr seqDataType "empty" [] Prefix
727 consConstr = mkConstr seqDataType "<|" [] Infix
728
729 seqDataType :: DataType
730 seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
731 #endif
732
733 -- Finger trees
734
735 data FingerTree a
736 = EmptyT
737 | Single a
738 | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
739 #if TESTING
740 deriving Show
741 #endif
742
743 instance Sized a => Sized (FingerTree a) where
744 {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
745 {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
746 size EmptyT = 0
747 size (Single x) = size x
748 size (Deep v _ _ _) = v
749
750 instance Foldable FingerTree where
751 foldMap _ EmptyT = mempty
752 foldMap f (Single x) = f x
753 foldMap f (Deep _ pr m sf) =
754 foldMap f pr <> foldMap (foldMap f) m <> foldMap f sf
755
756 foldr _ z EmptyT = z
757 foldr f z (Single x) = x `f` z
758 foldr f z (Deep _ pr m sf) =
759 foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
760
761 foldl _ z EmptyT = z
762 foldl f z (Single x) = z `f` x
763 foldl f z (Deep _ pr m sf) =
764 foldl f (foldl (foldl f) (foldl f z pr) m) sf
765
766 foldr1 _ EmptyT = error "foldr1: empty sequence"
767 foldr1 _ (Single x) = x
768 foldr1 f (Deep _ pr m sf) =
769 foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
770
771 foldl1 _ EmptyT = error "foldl1: empty sequence"
772 foldl1 _ (Single x) = x
773 foldl1 f (Deep _ pr m sf) =
774 foldl f (foldl (foldl f) (foldl1 f pr) m) sf
775
776 instance Functor FingerTree where
777 fmap _ EmptyT = EmptyT
778 fmap f (Single x) = Single (f x)
779 fmap f (Deep v pr m sf) =
780 Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
781
782 instance Traversable FingerTree where
783 traverse _ EmptyT = pure EmptyT
784 traverse f (Single x) = Single <$> f x
785 traverse f (Deep v pr m sf) =
786 deep' v <$> traverse f pr <*> traverse (traverse f) m <*>
787 traverse f sf
788
789 instance NFData a => NFData (FingerTree a) where
790 rnf EmptyT = ()
791 rnf (Single x) = rnf x
792 rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m
793
794 {-# INLINE deep #-}
795 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
796 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
797
798 {-# INLINE pullL #-}
799 pullL :: Int -> FingerTree (Node a) -> Digit a -> FingerTree a
800 pullL s m sf = case viewLTree m of
801 EmptyLTree -> digitToTree' s sf
802 ConsLTree pr m' -> Deep s (nodeToDigit pr) m' sf
803
804 {-# INLINE pullR #-}
805 pullR :: Int -> Digit a -> FingerTree (Node a) -> FingerTree a
806 pullR s pr m = case viewRTree m of
807 EmptyRTree -> digitToTree' s pr
808 SnocRTree m' sf -> Deep s pr m' (nodeToDigit sf)
809
810 -- Digits
811
812 data Digit a
813 = One a
814 | Two a a
815 | Three a a a
816 | Four a a a a
817 #if TESTING
818 deriving Show
819 #endif
820
821 instance Foldable Digit where
822 foldMap f (One a) = f a
823 foldMap f (Two a b) = f a <> f b
824 foldMap f (Three a b c) = f a <> f b <> f c
825 foldMap f (Four a b c d) = f a <> f b <> f c <> f d
826
827 foldr f z (One a) = a `f` z
828 foldr f z (Two a b) = a `f` (b `f` z)
829 foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
830 foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
831
832 foldl f z (One a) = z `f` a
833 foldl f z (Two a b) = (z `f` a) `f` b
834 foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
835 foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
836
837 foldr1 _ (One a) = a
838 foldr1 f (Two a b) = a `f` b
839 foldr1 f (Three a b c) = a `f` (b `f` c)
840 foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
841
842 foldl1 _ (One a) = a
843 foldl1 f (Two a b) = a `f` b
844 foldl1 f (Three a b c) = (a `f` b) `f` c
845 foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
846
847 instance Functor Digit where
848 {-# INLINE fmap #-}
849 fmap f (One a) = One (f a)
850 fmap f (Two a b) = Two (f a) (f b)
851 fmap f (Three a b c) = Three (f a) (f b) (f c)
852 fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
853
854 instance Traversable Digit where
855 {-# INLINE traverse #-}
856 traverse f (One a) = One <$> f a
857 traverse f (Two a b) = Two <$> f a <*> f b
858 traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
859 traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
860
861 instance NFData a => NFData (Digit a) where
862 rnf (One a) = rnf a
863 rnf (Two a b) = rnf a `seq` rnf b
864 rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c
865 rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
866
867 instance Sized a => Sized (Digit a) where
868 {-# INLINE size #-}
869 size = foldl1 (+) . fmap size
870
871 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
872 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
873 digitToTree :: Sized a => Digit a -> FingerTree a
874 digitToTree (One a) = Single a
875 digitToTree (Two a b) = deep (One a) EmptyT (One b)
876 digitToTree (Three a b c) = deep (Two a b) EmptyT (One c)
877 digitToTree (Four a b c d) = deep (Two a b) EmptyT (Two c d)
878
879 -- | Given the size of a digit and the digit itself, efficiently converts
880 -- it to a FingerTree.
881 digitToTree' :: Int -> Digit a -> FingerTree a
882 digitToTree' n (Four a b c d) = Deep n (Two a b) EmptyT (Two c d)
883 digitToTree' n (Three a b c) = Deep n (Two a b) EmptyT (One c)
884 digitToTree' n (Two a b) = Deep n (One a) EmptyT (One b)
885 digitToTree' !_n (One a) = Single a
886
887 -- Nodes
888
889 data Node a
890 = Node2 {-# UNPACK #-} !Int a a
891 | Node3 {-# UNPACK #-} !Int a a a
892 #if TESTING
893 deriving Show
894 #endif
895
896 -- Sometimes, we need to apply a Node2, Node3, or Deep constructor
897 -- to a size and pass the result to a function. If we calculate,
898 -- say, `Node2 n <$> x <*> y`, then according to -ddump-simpl,
899 -- GHC boxes up `n`, passes it to the strict constructor for `Node2`,
900 -- and passes the result to `fmap`. Using `node2'` instead prevents
901 -- this, forming a closure with the unboxed size.
902 {-# INLINE node2' #-}
903 node2' :: Int -> a -> a -> Node a
904 node2' !s = \a b -> Node2 s a b
905
906 {-# INLINE node3' #-}
907 node3' :: Int -> a -> a -> a -> Node a
908 node3' !s = \a b c -> Node3 s a b c
909
910 {-# INLINE deep' #-}
911 deep' :: Int -> Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
912 deep' !s = \pr m sf -> Deep s pr m sf
913
914 instance Foldable Node where
915 foldMap f (Node2 _ a b) = f a <> f b
916 foldMap f (Node3 _ a b c) = f a <> f b <> f c
917
918 foldr f z (Node2 _ a b) = a `f` (b `f` z)
919 foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
920
921 foldl f z (Node2 _ a b) = (z `f` a) `f` b
922 foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
923
924 instance Functor Node where
925 {-# INLINE fmap #-}
926 fmap f (Node2 v a b) = Node2 v (f a) (f b)
927 fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
928
929 instance Traversable Node where
930 {-# INLINE traverse #-}
931 traverse f (Node2 v a b) = node2' v <$> f a <*> f b
932 traverse f (Node3 v a b c) = node3' v <$> f a <*> f b <*> f c
933
934 instance NFData a => NFData (Node a) where
935 rnf (Node2 _ a b) = rnf a `seq` rnf b
936 rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c
937
938 instance Sized (Node a) where
939 size (Node2 v _ _) = v
940 size (Node3 v _ _ _) = v
941
942 {-# INLINE node2 #-}
943 node2 :: Sized a => a -> a -> Node a
944 node2 a b = Node2 (size a + size b) a b
945
946 {-# INLINE node3 #-}
947 node3 :: Sized a => a -> a -> a -> Node a
948 node3 a b c = Node3 (size a + size b + size c) a b c
949
950 nodeToDigit :: Node a -> Digit a
951 nodeToDigit (Node2 _ a b) = Two a b
952 nodeToDigit (Node3 _ a b c) = Three a b c
953
954 -- Elements
955
956 newtype Elem a = Elem { getElem :: a }
957 #if TESTING
958 deriving Show
959 #endif
960
961 instance Sized (Elem a) where
962 size _ = 1
963
964 instance Functor Elem where
965 #if __GLASGOW_HASKELL__ >= 708
966 -- This cuts the time for <*> by around a fifth.
967 fmap = coerce
968 #else
969 fmap f (Elem x) = Elem (f x)
970 #endif
971
972 instance Foldable Elem where
973 foldMap f (Elem x) = f x
974 foldr f z (Elem x) = f x z
975 foldl f z (Elem x) = f z x
976
977 instance Traversable Elem where
978 traverse f (Elem x) = Elem <$> f x
979
980 instance NFData a => NFData (Elem a) where
981 rnf (Elem x) = rnf x
982
983 -------------------------------------------------------
984 -- Applicative construction
985 -------------------------------------------------------
986 #if !MIN_VERSION_base(4,8,0)
987 newtype Identity a = Identity {runIdentity :: a}
988
989 instance Functor Identity where
990 fmap f (Identity x) = Identity (f x)
991
992 instance Applicative Identity where
993 pure = Identity
994 Identity f <*> Identity x = Identity (f x)
995 #endif
996
997 -- | This is essentially a clone of Control.Monad.State.Strict.
998 newtype State s a = State {runState :: s -> (s, a)}
999
1000 instance Functor (State s) where
1001 fmap = liftA
1002
1003 instance Monad (State s) where
1004 {-# INLINE return #-}
1005 {-# INLINE (>>=) #-}
1006 return = pure
1007 m >>= k = State $ \ s -> case runState m s of
1008 (s', x) -> runState (k x) s'
1009
1010 instance Applicative (State s) where
1011 {-# INLINE pure #-}
1012 pure x = State $ \ s -> (s, x)
1013 (<*>) = ap
1014
1015 execState :: State s a -> s -> a
1016 execState m x = snd (runState m x)
1017
1018 -- | 'applicativeTree' takes an Applicative-wrapped construction of a
1019 -- piece of a FingerTree, assumed to always have the same size (which
1020 -- is put in the second argument), and replicates it as many times as
1021 -- specified. This is a generalization of 'replicateA', which itself
1022 -- is a generalization of many Data.Sequence methods.
1023 {-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
1024 {-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}
1025 -- Special note: the Identity specialization automatically does node sharing,
1026 -- reducing memory usage of the resulting tree to /O(log n)/.
1027 applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
1028 applicativeTree n !mSize m = case n of
1029 0 -> pure EmptyT
1030 1 -> fmap Single m
1031 2 -> deepA one emptyTree one
1032 3 -> deepA two emptyTree one
1033 4 -> deepA two emptyTree two
1034 5 -> deepA three emptyTree two
1035 6 -> deepA three emptyTree three
1036 _ -> case n `quotRem` 3 of
1037 (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three
1038 (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two
1039 (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two
1040 where !mSize' = 3 * mSize
1041 n3 = liftA3 (node3' mSize') m m m
1042 where
1043 one = fmap One m
1044 two = liftA2 Two m m
1045 three = liftA3 Three m m m
1046 deepA = liftA3 (deep' (n * mSize))
1047 emptyTree = pure EmptyT
1048
1049 ------------------------------------------------------------------------
1050 -- Construction
1051 ------------------------------------------------------------------------
1052
1053 -- | /O(1)/. The empty sequence.
1054 empty :: Seq a
1055 empty = Seq EmptyT
1056
1057 -- | /O(1)/. A singleton sequence.
1058 singleton :: a -> Seq a
1059 singleton x = Seq (Single (Elem x))
1060
1061 -- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.
1062 replicate :: Int -> a -> Seq a
1063 replicate n x
1064 | n >= 0 = runIdentity (replicateA n (Identity x))
1065 | otherwise = error "replicate takes a nonnegative integer argument"
1066
1067 -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
1068 -- /O(log n)/ calls to '<*>' and 'pure'.
1069 --
1070 -- > replicateA n x = sequenceA (replicate n x)
1071 replicateA :: Applicative f => Int -> f a -> f (Seq a)
1072 replicateA n x
1073 | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
1074 | otherwise = error "replicateA takes a nonnegative integer argument"
1075
1076 -- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
1077 --
1078 -- > replicateM n x = sequence (replicate n x)
1079 replicateM :: Monad m => Int -> m a -> m (Seq a)
1080 replicateM n x
1081 | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
1082 | otherwise = error "replicateM takes a nonnegative integer argument"
1083
1084 -- | /O(log(k))/. @'cycleTaking' k xs@ forms a sequence of length @k@ by
1085 -- repeatedly concatenating @xs@ with itself. @xs@ may only be empty if
1086 -- @k@ is 0.
1087 --
1088 -- prop> cycleTaking k = fromList . take k . cycle . toList
1089
1090 -- If you wish to concatenate a non-empty sequence @xs@ with itself precisely
1091 -- @k@ times, you can use @cycleTaking (k * length xs)@ or just
1092 -- @replicate k () *> xs@.
1093 --
1094 -- @since 0.5.8
1095 cycleTaking :: Int -> Seq a -> Seq a
1096 cycleTaking n !_xs | n <= 0 = empty
1097 cycleTaking _n xs | null xs = error "cycleTaking cannot take a positive number of elements from an empty cycle."
1098 cycleTaking n xs = cycleNTimes reps xs >< take final xs
1099 where
1100 (reps, final) = n `quotRem` length xs
1101
1102 -- | /O(log(kn))/. @'cycleNTimes' k xs@ concatenates @k@ copies of @xs@. This
1103 -- operation uses time and additional space logarithmic in the size of its
1104 -- result.
1105 cycleNTimes :: Int -> Seq a -> Seq a
1106 cycleNTimes n !xs
1107 | n <= 0 = empty
1108 | n == 1 = xs
1109 cycleNTimes n (Seq xsFT) = case rigidify xsFT of
1110 RigidEmpty -> empty
1111 RigidOne (Elem x) -> replicate n x
1112 RigidTwo x1 x2 -> Seq $
1113 Deep (n*2) pair
1114 (runIdentity $ applicativeTree (n-2) 2 (Identity (node2 x1 x2)))
1115 pair
1116 where pair = Two x1 x2
1117 RigidThree x1 x2 x3 -> Seq $
1118 Deep (n*3) triple
1119 (runIdentity $ applicativeTree (n-2) 3 (Identity (node3 x1 x2 x3)))
1120 triple
1121 where triple = Three x1 x2 x3
1122 RigidFull r@(Rigid s pr _m sf) -> Seq $
1123 Deep (n*s)
1124 (nodeToDigit pr)
1125 (cycleNMiddle (n-2) r)
1126 (nodeToDigit sf)
1127
1128 cycleNMiddle
1129 :: Int
1130 -> Rigid c
1131 -> FingerTree (Node c)
1132
1133 -- Not at the bottom yet
1134
1135 cycleNMiddle !n
1136 (Rigid s pr (DeepTh sm prm mm sfm) sf)
1137 = Deep (sm + s * (n + 1)) -- note: sm = s - size pr - size sf
1138 (digit12ToDigit prm)
1139 (cycleNMiddle n
1140 (Rigid s (squashL pr prm) mm (squashR sfm sf)))
1141 (digit12ToDigit sfm)
1142
1143 -- At the bottom
1144
1145 cycleNMiddle n
1146 (Rigid s pr EmptyTh sf)
1147 = deep
1148 (One sf)
1149 (runIdentity $ applicativeTree n s (Identity converted))
1150 (One pr)
1151 where converted = node2 pr sf
1152
1153 cycleNMiddle n
1154 (Rigid s pr (SingleTh q) sf)
1155 = deep
1156 (Two q sf)
1157 (runIdentity $ applicativeTree n s (Identity converted))
1158 (Two pr q)
1159 where converted = node3 pr q sf
1160
1161
1162 -- | /O(1)/. Add an element to the left end of a sequence.
1163 -- Mnemonic: a triangle with the single element at the pointy end.
1164 (<|) :: a -> Seq a -> Seq a
1165 x <| Seq xs = Seq (Elem x `consTree` xs)
1166
1167 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
1168 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
1169 consTree :: Sized a => a -> FingerTree a -> FingerTree a
1170 consTree a EmptyT = Single a
1171 consTree a (Single b) = deep (One a) EmptyT (One b)
1172 -- As described in the paper, we force the middle of a tree
1173 -- *before* consing onto it; this preserves the amortized
1174 -- bounds but prevents repeated consing from building up
1175 -- gigantic suspensions.
1176 consTree a (Deep s (Four b c d e) m sf) = m `seq`
1177 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
1178 consTree a (Deep s (Three b c d) m sf) =
1179 Deep (size a + s) (Four a b c d) m sf
1180 consTree a (Deep s (Two b c) m sf) =
1181 Deep (size a + s) (Three a b c) m sf
1182 consTree a (Deep s (One b) m sf) =
1183 Deep (size a + s) (Two a b) m sf
1184
1185 -- | /O(1)/. Add an element to the right end of a sequence.
1186 -- Mnemonic: a triangle with the single element at the pointy end.
1187 (|>) :: Seq a -> a -> Seq a
1188 Seq xs |> x = Seq (xs `snocTree` Elem x)
1189
1190 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
1191 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
1192 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
1193 snocTree EmptyT a = Single a
1194 snocTree (Single a) b = deep (One a) EmptyT (One b)
1195 -- See note on `seq` in `consTree`.
1196 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
1197 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
1198 snocTree (Deep s pr m (Three a b c)) d =
1199 Deep (s + size d) pr m (Four a b c d)
1200 snocTree (Deep s pr m (Two a b)) c =
1201 Deep (s + size c) pr m (Three a b c)
1202 snocTree (Deep s pr m (One a)) b =
1203 Deep (s + size b) pr m (Two a b)
1204
1205 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
1206 (><) :: Seq a -> Seq a -> Seq a
1207 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
1208
1209 -- The appendTree/addDigits gunk below is machine generated
1210
1211 appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
1212 appendTree0 EmptyT xs =
1213 xs
1214 appendTree0 xs EmptyT =
1215 xs
1216 appendTree0 (Single x) xs =
1217 x `consTree` xs
1218 appendTree0 xs (Single x) =
1219 xs `snocTree` x
1220 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
1221 Deep (s1 + s2) pr1 m sf2
1222 where !m = addDigits0 m1 sf1 pr2 m2
1223
1224 addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
1225 addDigits0 m1 (One a) (One b) m2 =
1226 appendTree1 m1 (node2 a b) m2
1227 addDigits0 m1 (One a) (Two b c) m2 =
1228 appendTree1 m1 (node3 a b c) m2
1229 addDigits0 m1 (One a) (Three b c d) m2 =
1230 appendTree2 m1 (node2 a b) (node2 c d) m2
1231 addDigits0 m1 (One a) (Four b c d e) m2 =
1232 appendTree2 m1 (node3 a b c) (node2 d e) m2
1233 addDigits0 m1 (Two a b) (One c) m2 =
1234 appendTree1 m1 (node3 a b c) m2
1235 addDigits0 m1 (Two a b) (Two c d) m2 =
1236 appendTree2 m1 (node2 a b) (node2 c d) m2
1237 addDigits0 m1 (Two a b) (Three c d e) m2 =
1238 appendTree2 m1 (node3 a b c) (node2 d e) m2
1239 addDigits0 m1 (Two a b) (Four c d e f) m2 =
1240 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1241 addDigits0 m1 (Three a b c) (One d) m2 =
1242 appendTree2 m1 (node2 a b) (node2 c d) m2
1243 addDigits0 m1 (Three a b c) (Two d e) m2 =
1244 appendTree2 m1 (node3 a b c) (node2 d e) m2
1245 addDigits0 m1 (Three a b c) (Three d e f) m2 =
1246 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1247 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
1248 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1249 addDigits0 m1 (Four a b c d) (One e) m2 =
1250 appendTree2 m1 (node3 a b c) (node2 d e) m2
1251 addDigits0 m1 (Four a b c d) (Two e f) m2 =
1252 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1253 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
1254 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1255 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
1256 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1257
1258 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1259 appendTree1 EmptyT !a xs =
1260 a `consTree` xs
1261 appendTree1 xs !a EmptyT =
1262 xs `snocTree` a
1263 appendTree1 (Single x) !a xs =
1264 x `consTree` a `consTree` xs
1265 appendTree1 xs !a (Single x) =
1266 xs `snocTree` a `snocTree` x
1267 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
1268 Deep (s1 + size a + s2) pr1 m sf2
1269 where !m = addDigits1 m1 sf1 a pr2 m2
1270
1271 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1272 addDigits1 m1 (One a) b (One c) m2 =
1273 appendTree1 m1 (node3 a b c) m2
1274 addDigits1 m1 (One a) b (Two c d) m2 =
1275 appendTree2 m1 (node2 a b) (node2 c d) m2
1276 addDigits1 m1 (One a) b (Three c d e) m2 =
1277 appendTree2 m1 (node3 a b c) (node2 d e) m2
1278 addDigits1 m1 (One a) b (Four c d e f) m2 =
1279 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1280 addDigits1 m1 (Two a b) c (One d) m2 =
1281 appendTree2 m1 (node2 a b) (node2 c d) m2
1282 addDigits1 m1 (Two a b) c (Two d e) m2 =
1283 appendTree2 m1 (node3 a b c) (node2 d e) m2
1284 addDigits1 m1 (Two a b) c (Three d e f) m2 =
1285 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1286 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
1287 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1288 addDigits1 m1 (Three a b c) d (One e) m2 =
1289 appendTree2 m1 (node3 a b c) (node2 d e) m2
1290 addDigits1 m1 (Three a b c) d (Two e f) m2 =
1291 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1292 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
1293 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1294 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
1295 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1296 addDigits1 m1 (Four a b c d) e (One f) m2 =
1297 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1298 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
1299 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1300 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
1301 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1302 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
1303 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1304
1305 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1306 appendTree2 EmptyT !a !b xs =
1307 a `consTree` b `consTree` xs
1308 appendTree2 xs !a !b EmptyT =
1309 xs `snocTree` a `snocTree` b
1310 appendTree2 (Single x) a b xs =
1311 x `consTree` a `consTree` b `consTree` xs
1312 appendTree2 xs a b (Single x) =
1313 xs `snocTree` a `snocTree` b `snocTree` x
1314 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
1315 Deep (s1 + size a + size b + s2) pr1 m sf2
1316 where !m = addDigits2 m1 sf1 a b pr2 m2
1317
1318 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
1319 addDigits2 m1 (One a) b c (One d) m2 =
1320 appendTree2 m1 (node2 a b) (node2 c d) m2
1321 addDigits2 m1 (One a) b c (Two d e) m2 =
1322 appendTree2 m1 (node3 a b c) (node2 d e) m2
1323 addDigits2 m1 (One a) b c (Three d e f) m2 =
1324 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1325 addDigits2 m1 (One a) b c (Four d e f g) m2 =
1326 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1327 addDigits2 m1 (Two a b) c d (One e) m2 =
1328 appendTree2 m1 (node3 a b c) (node2 d e) m2
1329 addDigits2 m1 (Two a b) c d (Two e f) m2 =
1330 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1331 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
1332 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1333 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
1334 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1335 addDigits2 m1 (Three a b c) d e (One f) m2 =
1336 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1337 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
1338 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1339 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
1340 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1341 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
1342 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1343 addDigits2 m1 (Four a b c d) e f (One g) m2 =
1344 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1345 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
1346 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1347 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
1348 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1349 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
1350 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1351
1352 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1353 appendTree3 EmptyT !a !b !c xs =
1354 a `consTree` b `consTree` c `consTree` xs
1355 appendTree3 xs !a !b !c EmptyT =
1356 xs `snocTree` a `snocTree` b `snocTree` c
1357 appendTree3 (Single x) a b c xs =
1358 x `consTree` a `consTree` b `consTree` c `consTree` xs
1359 appendTree3 xs a b c (Single x) =
1360 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
1361 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
1362 Deep (s1 + size a + size b + size c + s2) pr1 m sf2
1363 where !m = addDigits3 m1 sf1 a b c pr2 m2
1364
1365 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))
1366 addDigits3 m1 (One a) !b !c !d (One e) m2 =
1367 appendTree2 m1 (node3 a b c) (node2 d e) m2
1368 addDigits3 m1 (One a) b c d (Two e f) m2 =
1369 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1370 addDigits3 m1 (One a) b c d (Three e f g) m2 =
1371 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1372 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
1373 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1374 addDigits3 m1 (Two a b) !c !d !e (One f) m2 =
1375 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1376 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
1377 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1378 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
1379 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1380 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
1381 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1382 addDigits3 m1 (Three a b c) !d !e !f (One g) m2 =
1383 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1384 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
1385 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1386 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
1387 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1388 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
1389 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1390 addDigits3 m1 (Four a b c d) !e !f !g (One h) m2 =
1391 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1392 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
1393 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1394 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
1395 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1396 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
1397 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1398
1399 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
1400 appendTree4 EmptyT !a !b !c !d xs =
1401 a `consTree` b `consTree` c `consTree` d `consTree` xs
1402 appendTree4 xs !a !b !c !d EmptyT =
1403 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
1404 appendTree4 (Single x) a b c d xs =
1405 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
1406 appendTree4 xs a b c d (Single x) =
1407 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
1408 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
1409 Deep (s1 + size a + size b + size c + size d + s2) pr1 m sf2
1410 where !m = addDigits4 m1 sf1 a b c d pr2 m2
1411
1412 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))
1413 addDigits4 m1 (One a) !b !c !d !e (One f) m2 =
1414 appendTree2 m1 (node3 a b c) (node3 d e f) m2
1415 addDigits4 m1 (One a) b c d e (Two f g) m2 =
1416 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1417 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
1418 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1419 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
1420 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1421 addDigits4 m1 (Two a b) !c !d !e !f (One g) m2 =
1422 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
1423 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
1424 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1425 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
1426 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1427 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
1428 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1429 addDigits4 m1 (Three a b c) !d !e !f !g (One h) m2 =
1430 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
1431 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
1432 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1433 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
1434 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1435 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
1436 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1437 addDigits4 m1 (Four a b c d) !e !f !g !h (One i) m2 =
1438 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
1439 addDigits4 m1 (Four a b c d) !e !f !g !h (Two i j) m2 =
1440 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
1441 addDigits4 m1 (Four a b c d) !e !f !g !h (Three i j k) m2 =
1442 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
1443 addDigits4 m1 (Four a b c d) !e !f !g !h (Four i j k l) m2 =
1444 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
1445
1446 -- | Builds a sequence from a seed value. Takes time linear in the
1447 -- number of generated elements. /WARNING:/ If the number of generated
1448 -- elements is infinite, this method will not terminate.
1449 unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
1450 unfoldr f = unfoldr' empty
1451 -- uses tail recursion rather than, for instance, the List implementation.
1452 where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
1453
1454 -- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.
1455 unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
1456 unfoldl f = unfoldl' empty
1457 where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
1458
1459 -- | /O(n)/. Constructs a sequence by repeated application of a function
1460 -- to a seed value.
1461 --
1462 -- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
1463 iterateN :: Int -> (a -> a) -> a -> Seq a
1464 iterateN n f x
1465 | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
1466 | otherwise = error "iterateN takes a nonnegative integer argument"
1467
1468 ------------------------------------------------------------------------
1469 -- Deconstruction
1470 ------------------------------------------------------------------------
1471
1472 -- | /O(1)/. Is this the empty sequence?
1473 null :: Seq a -> Bool
1474 null (Seq EmptyT) = True
1475 null _ = False
1476
1477 -- | /O(1)/. The number of elements in the sequence.
1478 length :: Seq a -> Int
1479 length (Seq xs) = size xs
1480
1481 -- Views
1482
1483 data ViewLTree a = ConsLTree a (FingerTree a) | EmptyLTree
1484 data ViewRTree a = SnocRTree (FingerTree a) a | EmptyRTree
1485
1486 -- | View of the left end of a sequence.
1487 data ViewL a
1488 = EmptyL -- ^ empty sequence
1489 | a :< Seq a -- ^ leftmost element and the rest of the sequence
1490 #if __GLASGOW_HASKELL__
1491 deriving (Eq, Ord, Show, Read, Data)
1492 #else
1493 deriving (Eq, Ord, Show, Read)
1494 #endif
1495
1496 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
1497
1498 instance Functor ViewL where
1499 {-# INLINE fmap #-}
1500 fmap _ EmptyL = EmptyL
1501 fmap f (x :< xs) = f x :< fmap f xs
1502
1503 instance Foldable ViewL where
1504 foldr _ z EmptyL = z
1505 foldr f z (x :< xs) = f x (foldr f z xs)
1506
1507 foldl _ z EmptyL = z
1508 foldl f z (x :< xs) = foldl f (f z x) xs
1509
1510 foldl1 _ EmptyL = error "foldl1: empty view"
1511 foldl1 f (x :< xs) = foldl f x xs
1512
1513 instance Traversable ViewL where
1514 traverse _ EmptyL = pure EmptyL
1515 traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
1516
1517 -- | /O(1)/. Analyse the left end of a sequence.
1518 viewl :: Seq a -> ViewL a
1519 viewl (Seq xs) = case viewLTree xs of
1520 EmptyLTree -> EmptyL
1521 ConsLTree (Elem x) xs' -> x :< Seq xs'
1522
1523 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> ViewLTree (Elem a) #-}
1524 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> ViewLTree (Node a) #-}
1525 viewLTree :: Sized a => FingerTree a -> ViewLTree a
1526 viewLTree EmptyT = EmptyLTree
1527 viewLTree (Single a) = ConsLTree a EmptyT
1528 viewLTree (Deep s (One a) m sf) = ConsLTree a (pullL (s - size a) m sf)
1529 viewLTree (Deep s (Two a b) m sf) =
1530 ConsLTree a (Deep (s - size a) (One b) m sf)
1531 viewLTree (Deep s (Three a b c) m sf) =
1532 ConsLTree a (Deep (s - size a) (Two b c) m sf)
1533 viewLTree (Deep s (Four a b c d) m sf) =
1534 ConsLTree a (Deep (s - size a) (Three b c d) m sf)
1535
1536 -- | View of the right end of a sequence.
1537 data ViewR a
1538 = EmptyR -- ^ empty sequence
1539 | Seq a :> a -- ^ the sequence minus the rightmost element,
1540 -- and the rightmost element
1541 #if __GLASGOW_HASKELL__
1542 deriving (Eq, Ord, Show, Read, Data)
1543 #else
1544 deriving (Eq, Ord, Show, Read)
1545 #endif
1546
1547 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
1548
1549 instance Functor ViewR where
1550 {-# INLINE fmap #-}
1551 fmap _ EmptyR = EmptyR
1552 fmap f (xs :> x) = fmap f xs :> f x
1553
1554 instance Foldable ViewR where
1555 foldMap _ EmptyR = mempty
1556 foldMap f (xs :> x) = foldMap f xs <> f x
1557
1558 foldr _ z EmptyR = z
1559 foldr f z (xs :> x) = foldr f (f x z) xs
1560
1561 foldl _ z EmptyR = z
1562 foldl f z (xs :> x) = foldl f z xs `f` x
1563
1564 foldr1 _ EmptyR = error "foldr1: empty view"
1565 foldr1 f (xs :> x) = foldr f x xs
1566 #if MIN_VERSION_base(4,8,0)
1567 -- The default definitions are sensible for ViewL, but not so much for
1568 -- ViewR.
1569 null EmptyR = True
1570 null (_ :> _) = False
1571
1572 length = foldr' (\_ k -> k+1) 0
1573 #endif
1574
1575 instance Traversable ViewR where
1576 traverse _ EmptyR = pure EmptyR
1577 traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
1578
1579 -- | /O(1)/. Analyse the right end of a sequence.
1580 viewr :: Seq a -> ViewR a
1581 viewr (Seq xs) = case viewRTree xs of
1582 EmptyRTree -> EmptyR
1583 SnocRTree xs' (Elem x) -> Seq xs' :> x
1584
1585 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> ViewRTree (Elem a) #-}
1586 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> ViewRTree (Node a) #-}
1587 viewRTree :: Sized a => FingerTree a -> ViewRTree a
1588 viewRTree EmptyT = EmptyRTree
1589 viewRTree (Single z) = SnocRTree EmptyT z
1590 viewRTree (Deep s pr m (One z)) = SnocRTree (pullR (s - size z) pr m) z
1591 viewRTree (Deep s pr m (Two y z)) =
1592 SnocRTree (Deep (s - size z) pr m (One y)) z
1593 viewRTree (Deep s pr m (Three x y z)) =
1594 SnocRTree (Deep (s - size z) pr m (Two x y)) z
1595 viewRTree (Deep s pr m (Four w x y z)) =
1596 SnocRTree (Deep (s - size z) pr m (Three w x y)) z
1597
1598 ------------------------------------------------------------------------
1599 -- Scans
1600 --
1601 -- These are not particularly complex applications of the Traversable
1602 -- functor, though making the correspondence with Data.List exact
1603 -- requires the use of (<|) and (|>).
1604 --
1605 -- Note that save for the single (<|) or (|>), we maintain the original
1606 -- structure of the Seq, not having to do any restructuring of our own.
1607 --
1608 -- wasserman.louis@gmail.com, 5/23/09
1609 ------------------------------------------------------------------------
1610
1611 -- | 'scanl' is similar to 'foldl', but returns a sequence of reduced
1612 -- values from the left:
1613 --
1614 -- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
1615 scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
1616 scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
1617
1618 -- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
1619 --
1620 -- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
1621 scanl1 :: (a -> a -> a) -> Seq a -> Seq a
1622 scanl1 f xs = case viewl xs of
1623 EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
1624 x :< xs' -> scanl f x xs'
1625
1626 -- | 'scanr' is the right-to-left dual of 'scanl'.
1627 scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
1628 scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
1629
1630 -- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
1631 scanr1 :: (a -> a -> a) -> Seq a -> Seq a
1632 scanr1 f xs = case viewr xs of
1633 EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
1634 xs' :> x -> scanr f x xs'
1635
1636 -- Indexing
1637
1638 -- | /O(log(min(i,n-i)))/. The element at the specified position,
1639 -- counting from 0. The argument should thus be a non-negative
1640 -- integer less than the size of the sequence.
1641 -- If the position is out of range, 'index' fails with an error.
1642 --
1643 -- prop> xs `index` i = toList xs !! i
1644 index :: Seq a -> Int -> a
1645 index (Seq xs) i
1646 -- See note on unsigned arithmetic in splitAt
1647 | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of
1648 Place _ (Elem x) -> x
1649 | otherwise = error "index out of bounds"
1650
1651 -- | /O(log(min(i,n-i)))/. The element at the specified position,
1652 -- counting from 0. If the specified position is negative or at
1653 -- least the length of the sequence, 'lookup' returns 'Nothing'.
1654 --
1655 -- prop> 0 <= i < length xs ==> lookup i xs == Just (toList xs !! i)
1656 -- prop> i < 0 || i >= length xs ==> lookup i xs = Nothing
1657 --
1658 -- @since 0.5.8
1659 lookup :: Int -> Seq a -> Maybe a
1660 lookup i (Seq xs)
1661 -- Note: we perform the lookup *before* applying the Just constructor
1662 -- to ensure that we don't hold a reference to the whole sequence in
1663 -- a thunk. If we applied the Just constructor around the case, the
1664 -- actual lookup wouldn't be performed unless and until the value was
1665 -- forced.
1666 | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of
1667 Place _ (Elem x) -> Just x
1668 | otherwise = Nothing
1669
1670 -- | /O(log(min(i,n-i)))/. A flipped, infix version of `lookup`.
1671 --
1672 -- @since 0.5.8
1673 (!?) :: Seq a -> Int -> Maybe a
1674 (!?) = flip lookup
1675
1676 data Place a = Place {-# UNPACK #-} !Int a
1677 #if TESTING
1678 deriving Show
1679 #endif
1680
1681 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
1682 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
1683 lookupTree :: Sized a => Int -> FingerTree a -> Place a
1684 lookupTree !_ EmptyT = error "lookupTree of empty tree"
1685 lookupTree i (Single x) = Place i x
1686 lookupTree i (Deep _ pr m sf)
1687 | i < spr = lookupDigit i pr
1688 | i < spm = case lookupTree (i - spr) m of
1689 Place i' xs -> lookupNode i' xs
1690 | otherwise = lookupDigit (i - spm) sf
1691 where
1692 spr = size pr
1693 spm = spr + size m
1694
1695 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
1696 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
1697 lookupNode :: Sized a => Int -> Node a -> Place a
1698 lookupNode i (Node2 _ a b)
1699 | i < sa = Place i a
1700 | otherwise = Place (i - sa) b
1701 where
1702 sa = size a
1703 lookupNode i (Node3 _ a b c)
1704 | i < sa = Place i a
1705 | i < sab = Place (i - sa) b
1706 | otherwise = Place (i - sab) c
1707 where
1708 sa = size a
1709 sab = sa + size b
1710
1711 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
1712 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
1713 lookupDigit :: Sized a => Int -> Digit a -> Place a
1714 lookupDigit i (One a) = Place i a
1715 lookupDigit i (Two a b)
1716 | i < sa = Place i a
1717 | otherwise = Place (i - sa) b
1718 where
1719 sa = size a
1720 lookupDigit i (Three a b c)
1721 | i < sa = Place i a
1722 | i < sab = Place (i - sa) b
1723 | otherwise = Place (i - sab) c
1724 where
1725 sa = size a
1726 sab = sa + size b
1727 lookupDigit i (Four a b c d)
1728 | i < sa = Place i a
1729 | i < sab = Place (i - sa) b
1730 | i < sabc = Place (i - sab) c
1731 | otherwise = Place (i - sabc) d
1732 where
1733 sa = size a
1734 sab = sa + size b
1735 sabc = sab + size c
1736
1737 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position.
1738 -- If the position is out of range, the original sequence is returned.
1739 update :: Int -> a -> Seq a -> Seq a
1740 update i x (Seq xs)
1741 -- See note on unsigned arithmetic in splitAt
1742 | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (updateTree (Elem x) i xs)
1743 | otherwise = Seq xs
1744
1745 -- It seems a shame to copy the implementation of the top layer of
1746 -- `adjust` instead of just using `update i x = adjust (const x) i`.
1747 -- With the latter implementation, updating the same position many
1748 -- times could lead to silly thunks building up around that position.
1749 -- The thunks will each look like @const v a@, where @v@ is the new
1750 -- value and @a@ the old.
1751 updateTree :: Elem a -> Int -> FingerTree (Elem a) -> FingerTree (Elem a)
1752 updateTree _ !_ EmptyT = EmptyT -- Unreachable
1753 updateTree v _i (Single _) = Single v
1754 updateTree v i (Deep s pr m sf)
1755 | i < spr = Deep s (updateDigit v i pr) m sf
1756 | i < spm = let !m' = adjustTree (updateNode v) (i - spr) m
1757 in Deep s pr m' sf
1758 | otherwise = Deep s pr m (updateDigit v (i - spm) sf)
1759 where
1760 spr = size pr
1761 spm = spr + size m
1762
1763 updateNode :: Elem a -> Int -> Node (Elem a) -> Node (Elem a)
1764 updateNode v i (Node2 s a b)
1765 | i < sa = Node2 s v b
1766 | otherwise = Node2 s a v
1767 where
1768 sa = size a
1769 updateNode v i (Node3 s a b c)
1770 | i < sa = Node3 s v b c
1771 | i < sab = Node3 s a v c
1772 | otherwise = Node3 s a b v
1773 where
1774 sa = size a
1775 sab = sa + size b
1776
1777 updateDigit :: Elem a -> Int -> Digit (Elem a) -> Digit (Elem a)
1778 updateDigit v !_i (One _) = One v
1779 updateDigit v i (Two a b)
1780 | i < sa = Two v b
1781 | otherwise = Two a v
1782 where
1783 sa = size a
1784 updateDigit v i (Three a b c)
1785 | i < sa = Three v b c
1786 | i < sab = Three a v c
1787 | otherwise = Three a b v
1788 where
1789 sa = size a
1790 sab = sa + size b
1791 updateDigit v i (Four a b c d)
1792 | i < sa = Four v b c d
1793 | i < sab = Four a v c d
1794 | i < sabc = Four a b v d
1795 | otherwise = Four a b c v
1796 where
1797 sa = size a
1798 sab = sa + size b
1799 sabc = sab + size c
1800
1801 -- | /O(log(min(i,n-i)))/. Update the element at the specified position.
1802 -- If the position is out of range, the original sequence is returned.
1803 adjust :: (a -> a) -> Int -> Seq a -> Seq a
1804 adjust f i (Seq xs)
1805 -- See note on unsigned arithmetic in splitAt
1806 | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (adjustTree (`seq` fmap f) i xs)
1807 | otherwise = Seq xs
1808
1809 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
1810 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
1811 adjustTree :: (Sized a, MaybeForce a) => (Int -> a -> a) ->
1812 Int -> FingerTree a -> FingerTree a
1813 adjustTree _ !_ EmptyT = EmptyT -- Unreachable
1814 adjustTree f i (Single x) = Single $!? f i x
1815 adjustTree f i (Deep s pr m sf)
1816 | i < spr = Deep s (adjustDigit f i pr) m sf
1817 | i < spm = let !m' = adjustTree (adjustNode f) (i - spr) m
1818 in Deep s pr m' sf
1819 | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
1820 where
1821 spr = size pr
1822 spm = spr + size m
1823
1824 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
1825 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
1826 adjustNode :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Node a -> Node a
1827 adjustNode f i (Node2 s a b)
1828 | i < sa = let fia = f i a in fia `mseq` Node2 s fia b
1829 | otherwise = let fisab = f (i - sa) b in fisab `mseq` Node2 s a fisab
1830 where
1831 sa = size a
1832 adjustNode f i (Node3 s a b c)
1833 | i < sa = let fia = f i a in fia `mseq` Node3 s fia b c
1834 | i < sab = let fisab = f (i - sa) b in fisab `mseq` Node3 s a fisab c
1835 | otherwise = let fisabc = f (i - sab) c in fisabc `mseq` Node3 s a b fisabc
1836 where
1837 sa = size a
1838 sab = sa + size b
1839
1840 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
1841 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
1842 adjustDigit :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Digit a -> Digit a
1843 adjustDigit f !i (One a) = One $!? f i a
1844 adjustDigit f i (Two a b)
1845 | i < sa = let fia = f i a in fia `mseq` Two fia b
1846 | otherwise = let fisab = f (i - sa) b in fisab `mseq` Two a fisab
1847 where
1848 sa = size a
1849 adjustDigit f i (Three a b c)
1850 | i < sa = let fia = f i a in fia `mseq` Three fia b c
1851 | i < sab = let fisab = f (i - sa) b in fisab `mseq` Three a fisab c
1852 | otherwise = let fisabc = f (i - sab) c in fisabc `mseq` Three a b fisabc
1853 where
1854 sa = size a
1855 sab = sa + size b
1856 adjustDigit f i (Four a b c d)
1857 | i < sa = let fia = f i a in fia `mseq` Four fia b c d
1858 | i < sab = let fisab = f (i - sa) b in fisab `mseq` Four a fisab c d
1859 | i < sabc = let fisabc = f (i - sab) c in fisabc `mseq` Four a b fisabc d
1860 | otherwise = let fisabcd = f (i - sabc) d in fisabcd `mseq` Four a b c fisabcd
1861 where
1862 sa = size a
1863 sab = sa + size b
1864 sabc = sab + size c
1865
1866 -- | /O(log(min(i,n-i)))/. @'insertAt' i x xs@ inserts @x@ into @xs@
1867 -- at the index @i@, shifting the rest of the sequence over.
1868 --
1869 -- @
1870 -- insertAt 2 x (fromList [a,b,c,d]) = fromList [a,b,x,c,d]
1871 -- insertAt 4 x (fromList [a,b,c,d]) = insertAt 10 x (fromList [a,b,c,d])
1872 -- = fromList [a,b,c,d,x]
1873 -- @
1874 --
1875 -- prop> insertAt i x xs = take i xs >< singleton x >< drop i xs
1876 --
1877 -- @since 0.5.8
1878 insertAt :: Int -> a -> Seq a -> Seq a
1879 insertAt i a s@(Seq xs)
1880 | fromIntegral i < (fromIntegral (size xs) :: Word)
1881 = Seq (insTree (`seq` InsTwo (Elem a)) i xs)
1882 | i <= 0 = a <| s
1883 | otherwise = s |> a
1884
1885 data Ins a = InsOne a | InsTwo a a
1886
1887 {-# SPECIALIZE insTree :: (Int -> Elem a -> Ins (Elem a)) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
1888 {-# SPECIALIZE insTree :: (Int -> Node a -> Ins (Node a)) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
1889 insTree :: Sized a => (Int -> a -> Ins a) ->
1890 Int -> FingerTree a -> FingerTree a
1891 insTree _ !_ EmptyT = EmptyT -- Unreachable
1892 insTree f i (Single x) = case f i x of
1893 InsOne x' -> Single x'
1894 InsTwo m n -> deep (One m) EmptyT (One n)
1895 insTree f i (Deep s pr m sf)
1896 | i < spr = case insLeftDigit f i pr of
1897 InsLeftDig pr' -> Deep (s + 1) pr' m sf
1898 InsDigNode pr' n -> m `seq` Deep (s + 1) pr' (n `consTree` m) sf
1899 | i < spm = let !m' = insTree (insNode f) (i - spr) m
1900 in Deep (s + 1) pr m' sf
1901 | otherwise = case insRightDigit f (i - spm) sf of
1902 InsRightDig sf' -> Deep (s + 1) pr m sf'
1903 InsNodeDig n sf' -> m `seq` Deep (s + 1) pr (m `snocTree` n) sf'
1904 where
1905 spr = size pr
1906 spm = spr + size m
1907
1908 {-# SPECIALIZE insNode :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Node (Elem a) -> Ins (Node (Elem a)) #-}
1909 {-# SPECIALIZE insNode :: (Int -> Node a -> Ins (Node a)) -> Int -> Node (Node a) -> Ins (Node (Node a)) #-}
1910 insNode :: Sized a => (Int -> a -> Ins a) -> Int -> Node a -> Ins (Node a)
1911 insNode f i (Node2 s a b)
1912 | i < sa = case f i a of
1913 InsOne n -> InsOne $ Node2 (s + 1) n b
1914 InsTwo m n -> InsOne $ Node3 (s + 1) m n b
1915 | otherwise = case f (i - sa) b of
1916 InsOne n -> InsOne $ Node2 (s + 1) a n
1917 InsTwo m n -> InsOne $ Node3 (s + 1) a m n
1918 where sa = size a
1919 insNode f i (Node3 s a b c)
1920 | i < sa = case f i a of
1921 InsOne n -> InsOne $ Node3 (s + 1) n b c
1922 InsTwo m n -> InsTwo (Node2 (sa + 1) m n) (Node2 (s - sa) b c)
1923 | i < sab = case f (i - sa) b of
1924 InsOne n -> InsOne $ Node3 (s + 1) a n c
1925 InsTwo m n -> InsTwo am nc
1926 where !am = node2 a m
1927 !nc = node2 n c
1928 | otherwise = case f (i - sab) c of
1929 InsOne n -> InsOne $ Node3 (s + 1) a b n
1930 InsTwo m n -> InsTwo (Node2 sab a b) (Node2 (s - sab + 1) m n)
1931 where sa = size a
1932 sab = sa + size b
1933
1934 data InsDigNode a = InsLeftDig !(Digit a) | InsDigNode !(Digit a) !(Node a)
1935 {-# SPECIALIZE insLeftDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsDigNode (Elem a) #-}
1936 {-# SPECIALIZE insLeftDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsDigNode (Node a) #-}
1937 insLeftDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsDigNode a
1938 insLeftDigit f !i (One a) = case f i a of
1939 InsOne a' -> InsLeftDig $ One a'
1940 InsTwo a1 a2 -> InsLeftDig $ Two a1 a2
1941 insLeftDigit f i (Two a b)
1942 | i < sa = case f i a of
1943 InsOne a' -> InsLeftDig $ Two a' b
1944 InsTwo a1 a2 -> InsLeftDig $ Three a1 a2 b
1945 | otherwise = case f (i - sa) b of
1946 InsOne b' -> InsLeftDig $ Two a b'
1947 InsTwo b1 b2 -> InsLeftDig $ Three a b1 b2
1948 where sa = size a
1949 insLeftDigit f i (Three a b c)
1950 | i < sa = case f i a of
1951 InsOne a' -> InsLeftDig $ Three a' b c
1952 InsTwo a1 a2 -> InsLeftDig $ Four a1 a2 b c
1953 | i < sab = case f (i - sa) b of
1954 InsOne b' -> InsLeftDig $ Three a b' c
1955 InsTwo b1 b2 -> InsLeftDig $ Four a b1 b2 c
1956 | otherwise = case f (i - sab) c of
1957 InsOne c' -> InsLeftDig $ Three a b c'
1958 InsTwo c1 c2 -> InsLeftDig $ Four a b c1 c2
1959 where sa = size a
1960 sab = sa + size b
1961 insLeftDigit f i (Four a b c d)
1962 | i < sa = case f i a of
1963 InsOne a' -> InsLeftDig $ Four a' b c d
1964 InsTwo a1 a2 -> InsDigNode (Two a1 a2) (node3 b c d)
1965 | i < sab = case f (i - sa) b of
1966 InsOne b' -> InsLeftDig $ Four a b' c d
1967 InsTwo b1 b2 -> InsDigNode (Two a b1) (node3 b2 c d)
1968 | i < sabc = case f (i - sab) c of
1969 InsOne c' -> InsLeftDig $ Four a b c' d
1970 InsTwo c1 c2 -> InsDigNode (Two a b) (node3 c1 c2 d)
1971 | otherwise = case f (i - sabc) d of
1972 InsOne d' -> InsLeftDig $ Four a b c d'
1973 InsTwo d1 d2 -> InsDigNode (Two a b) (node3 c d1 d2)
1974 where sa = size a
1975 sab = sa + size b
1976 sabc = sab + size c
1977
1978 data InsNodeDig a = InsRightDig !(Digit a) | InsNodeDig !(Node a) !(Digit a)
1979 {-# SPECIALIZE insRightDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsNodeDig (Elem a) #-}
1980 {-# SPECIALIZE insRightDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsNodeDig (Node a) #-}
1981 insRightDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsNodeDig a
1982 insRightDigit f !i (One a) = case f i a of
1983 InsOne a' -> InsRightDig $ One a'
1984 InsTwo a1 a2 -> InsRightDig $ Two a1 a2
1985 insRightDigit f i (Two a b)
1986 | i < sa = case f i a of
1987 InsOne a' -> InsRightDig $ Two a' b
1988 InsTwo a1 a2 -> InsRightDig $ Three a1 a2 b
1989 | otherwise = case f (i - sa) b of
1990 InsOne b' -> InsRightDig $ Two a b'
1991 InsTwo b1 b2 -> InsRightDig $ Three a b1 b2
1992 where sa = size a
1993 insRightDigit f i (Three a b c)
1994 | i < sa = case f i a of
1995 InsOne a' -> InsRightDig $ Three a' b c
1996 InsTwo a1 a2 -> InsRightDig $ Four a1 a2 b c
1997 | i < sab = case f (i - sa) b of
1998 InsOne b' -> InsRightDig $ Three a b' c
1999 InsTwo b1 b2 -> InsRightDig $ Four a b1 b2 c
2000 | otherwise = case f (i - sab) c of
2001 InsOne c' -> InsRightDig $ Three a b c'
2002 InsTwo c1 c2 -> InsRightDig $ Four a b c1 c2
2003 where sa = size a
2004 sab = sa + size b
2005 insRightDigit f i (Four a b c d)
2006 | i < sa = case f i a of
2007 InsOne a' -> InsRightDig $ Four a' b c d
2008 InsTwo a1 a2 -> InsNodeDig (node3 a1 a2 b) (Two c d)
2009 | i < sab = case f (i - sa) b of
2010 InsOne b' -> InsRightDig $ Four a b' c d
2011 InsTwo b1 b2 -> InsNodeDig (node3 a b1 b2) (Two c d)
2012 | i < sabc = case f (i - sab) c of
2013 InsOne c' -> InsRightDig $ Four a b c' d
2014 InsTwo c1 c2 -> InsNodeDig (node3 a b c1) (Two c2 d)
2015 | otherwise = case f (i - sabc) d of
2016 InsOne d' -> InsRightDig $ Four a b c d'
2017 InsTwo d1 d2 -> InsNodeDig (node3 a b c) (Two d1 d2)
2018 where sa = size a
2019 sab = sa + size b
2020 sabc = sab + size c
2021
2022 -- | /O(log(min(i,n-i)))/. Delete the element of a sequence at a given
2023 -- index. Return the original sequence if the index is out of range.
2024 --
2025 -- @
2026 -- deleteAt 2 [a,b,c,d] = [a,b,d]
2027 -- deleteAt 4 [a,b,c,d] = deleteAt (-1) [a,b,c,d] = [a,b,c,d]
2028 -- @
2029 --
2030 -- @since 0.5.8
2031 deleteAt :: Int -> Seq a -> Seq a
2032 deleteAt i (Seq xs)
2033 | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq $ delTreeE i xs
2034 | otherwise = Seq xs
2035
2036 delTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)
2037 delTreeE !_i EmptyT = EmptyT -- Unreachable
2038 delTreeE _i Single{} = EmptyT
2039 delTreeE i (Deep s pr m sf)
2040 | i < spr = delLeftDigitE i s pr m sf
2041 | i < spm = case delTree delNodeE (i - spr) m of
2042 FullTree m' -> Deep (s - 1) pr m' sf
2043 DefectTree e -> delRebuildMiddle (s - 1) pr e sf
2044 | otherwise = delRightDigitE (i - spm) s pr m sf
2045 where spr = size pr
2046 spm = spr + size m
2047
2048 delNodeE :: Int -> Node (Elem a) -> Del (Elem a)
2049 delNodeE i (Node3 _ a b c) = case i of
2050 0 -> Full $ Node2 2 b c
2051 1 -> Full $ Node2 2 a c
2052 _ -> Full $ Node2 2 a b
2053 delNodeE i (Node2 _ a b) = case i of
2054 0 -> Defect b
2055 _ -> Defect a
2056
2057
2058 delLeftDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)
2059 delLeftDigitE !_i s One{} m sf = pullL (s - 1) m sf
2060 delLeftDigitE i s (Two a b) m sf
2061 | i == 0 = Deep (s - 1) (One b) m sf
2062 | otherwise = Deep (s - 1) (One a) m sf
2063 delLeftDigitE i s (Three a b c) m sf
2064 | i == 0 = Deep (s - 1) (Two b c) m sf
2065 | i == 1 = Deep (s - 1) (Two a c) m sf
2066 | otherwise = Deep (s - 1) (Two a b) m sf
2067 delLeftDigitE i s (Four a b c d) m sf
2068 | i == 0 = Deep (s - 1) (Three b c d) m sf
2069 | i == 1 = Deep (s - 1) (Three a c d) m sf
2070 | i == 2 = Deep (s - 1) (Three a b d) m sf
2071 | otherwise = Deep (s - 1) (Three a b c) m sf
2072
2073 delRightDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)
2074 delRightDigitE !_i s pr m One{} = pullR (s - 1) pr m
2075 delRightDigitE i s pr m (Two a b)
2076 | i == 0 = Deep (s - 1) pr m (One b)
2077 | otherwise = Deep (s - 1) pr m (One a)
2078 delRightDigitE i s pr m (Three a b c)
2079 | i == 0 = Deep (s - 1) pr m (Two b c)
2080 | i == 1 = Deep (s - 1) pr m (Two a c)
2081 | otherwise = deep pr m (Two a b)
2082 delRightDigitE i s pr m (Four a b c d)
2083 | i == 0 = Deep (s - 1) pr m (Three b c d)
2084 | i == 1 = Deep (s - 1) pr m (Three a c d)
2085 | i == 2 = Deep (s - 1) pr m (Three a b d)
2086 | otherwise = Deep (s - 1) pr m (Three a b c)
2087
2088 data DelTree a = FullTree !(FingerTree (Node a)) | DefectTree a
2089
2090 {-# SPECIALIZE delTree :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> FingerTree (Node (Elem a)) -> DelTree (Elem a) #-}
2091 {-# SPECIALIZE delTree :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> FingerTree (Node (Node a)) -> DelTree (Node a) #-}
2092 delTree :: Sized a => (Int -> Node a -> Del a) -> Int -> FingerTree (Node a) -> DelTree a
2093 delTree _f !_i EmptyT = FullTree EmptyT -- Unreachable
2094 delTree f i (Single a) = case f i a of
2095 Full a' -> FullTree (Single a')
2096 Defect e -> DefectTree e
2097 delTree f i (Deep s pr m sf)
2098 | i < spr = case delDigit f i pr of
2099 FullDig pr' -> FullTree $ Deep (s - 1) pr' m sf
2100 DefectDig e -> case viewLTree m of
2101 EmptyLTree -> FullTree $ delRebuildRightDigit (s - 1) e sf
2102 ConsLTree n m' -> FullTree $ delRebuildLeftSide (s - 1) e n m' sf
2103 | i < spm = case delTree (delNode f) (i - spr) m of
2104 FullTree m' -> FullTree (Deep (s - 1) pr m' sf)
2105 DefectTree e -> FullTree $ delRebuildMiddle (s - 1) pr e sf
2106 | otherwise = case delDigit f (i - spm) sf of
2107 FullDig sf' -> FullTree $ Deep (s - 1) pr m sf'
2108 DefectDig e -> case viewRTree m of
2109 EmptyRTree -> FullTree $ delRebuildLeftDigit (s - 1) pr e
2110 SnocRTree m' n -> FullTree $ delRebuildRightSide (s - 1) pr m' n e
2111 where spr = size pr
2112 spm = spr + size m
2113
2114 data Del a = Full !(Node a) | Defect a
2115
2116 {-# SPECIALIZE delNode :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Node (Node (Elem a)) -> Del (Node (Elem a)) #-}
2117 {-# SPECIALIZE delNode :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Node (Node (Node a)) -> Del (Node (Node a)) #-}
2118 delNode :: Sized a => (Int -> Node a -> Del a) -> Int -> Node (Node a) -> Del (Node a)
2119 delNode f i (Node3 s a b c)
2120 | i < sa = case f i a of
2121 Full a' -> Full $ Node3 (s - 1) a' b c
2122 Defect e -> let !se = size e in case b of
2123 Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c
2124 where !sx = size x
2125 Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) e x y) c
2126 | i < sab = case f (i - sa) b of
2127 Full b' -> Full $ Node3 (s - 1) a b' c
2128 Defect e -> let !se = size e in case a of
2129 Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c
2130 where !sz = size z
2131 Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) x y e) c
2132 | otherwise = case f (i - sab) c of
2133 Full c' -> Full $ Node3 (s - 1) a b c'
2134 Defect e -> let !se = size e in case b of
2135 Node3 sxyz x y z -> Full $ Node3 (s - 1) a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
2136 where !sz = size z
2137 Node2 sxy x y -> Full $ Node2 (s - 1) a (Node3 (sxy + se) x y e)
2138 where sa = size a
2139 sab = sa + size b
2140 delNode f i (Node2 s a b)
2141 | i < sa = case f i a of
2142 Full a' -> Full $ Node2 (s - 1) a' b
2143 Defect e -> let !se = size e in case b of
2144 Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)
2145 where !sx = size x
2146 Node2 _ x y -> Defect $ Node3 (s - 1) e x y
2147 | otherwise = case f (i - sa) b of
2148 Full b' -> Full $ Node2 (s - 1) a b'
2149 Defect e -> let !se = size e in case a of
2150 Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
2151 where !sz = size z
2152 Node2 _ x y -> Defect $ Node3 (s - 1) x y e
2153 where sa = size a
2154
2155 {-# SPECIALIZE delRebuildRightDigit :: Int -> Elem a -> Digit (Node (Elem a)) -> FingerTree (Node (Elem a)) #-}
2156 {-# SPECIALIZE delRebuildRightDigit :: Int -> Node a -> Digit (Node (Node a)) -> FingerTree (Node (Node a)) #-}
2157 delRebuildRightDigit :: Sized a => Int -> a -> Digit (Node a) -> FingerTree (Node a)
2158 delRebuildRightDigit s p (One a) = let !sp = size p in case a of
2159 Node3 sxyz x y z -> Deep s (One (Node2 (sp + sx) p x)) EmptyT (One (Node2 (sxyz - sx) y z))
2160 where !sx = size x
2161 Node2 sxy x y -> Single (Node3 (sp + sxy) p x y)
2162 delRebuildRightDigit s p (Two a b) = let !sp = size p in case a of
2163 Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (One b)
2164 where !sx = size x
2165 Node2 sxy x y -> Deep s (One (Node3 (sp + sxy) p x y)) EmptyT (One b)
2166 delRebuildRightDigit s p (Three a b c) = let !sp = size p in case a of
2167 Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (Two b c)
2168 where !sx = size x
2169 Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (One c)
2170 delRebuildRightDigit s p (Four a b c d) = let !sp = size p in case a of
2171 Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) EmptyT (Two c d)
2172 where !sx = size x
2173 Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (Two c d)
2174
2175 {-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Elem a)) -> Elem a -> FingerTree (Node (Elem a)) #-}
2176 {-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Node a)) -> Node a -> FingerTree (Node (Node a)) #-}
2177 delRebuildLeftDigit :: Sized a => Int -> Digit (Node a) -> a -> FingerTree (Node a)
2178 delRebuildLeftDigit s (One a) p = let !sp = size p in case a of
2179 Node3 sxyz x y z -> Deep s (One (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))
2180 where !sz = size z
2181 Node2 sxy x y -> Single (Node3 (sxy + sp) x y p)
2182 delRebuildLeftDigit s (Two a b) p = let !sp = size p in case b of
2183 Node3 sxyz x y z -> Deep s (Two a (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))
2184 where !sz = size z
2185 Node2 sxy x y -> Deep s (One a) EmptyT (One (Node3 (sxy + sp) x y p))
2186 delRebuildLeftDigit s (Three a b c) p = let !sp = size p in case c of
2187 Node3 sxyz x y z -> Deep s (Two a b) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
2188 where !sz = size z
2189 Node2 sxy x y -> Deep s (Two a b) EmptyT (One (Node3 (sxy + sp) x y p))
2190 delRebuildLeftDigit s (Four a b c d) p = let !sp = size p in case d of
2191 Node3 sxyz x y z -> Deep s (Three a b c) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
2192 where !sz = size z
2193 Node2 sxy x y -> Deep s (Two a b) EmptyT (Two c (Node3 (sxy + sp) x y p))
2194
2195 delRebuildLeftSide :: Sized a
2196 => Int -> a -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)
2197 -> FingerTree (Node a)
2198 delRebuildLeftSide s p (Node2 _ a b) m sf = let !sp = size p in case a of
2199 Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) m sf
2200 Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) m sf
2201 where !sx = size x
2202 delRebuildLeftSide s p (Node3 _ a b c) m sf = let !sp = size p in case a of
2203 Node2 sxy x y -> Deep s (Three (Node3 (sp + sxy) p x y) b c) m sf
2204 Node3 sxyz x y z -> Deep s (Four (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b c) m sf
2205 where !sx = size x
2206
2207 delRebuildRightSide :: Sized a
2208 => Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> a
2209 -> FingerTree (Node a)
2210 delRebuildRightSide s pr m (Node2 _ a b) p = let !sp = size p in case b of
2211 Node2 sxy x y -> Deep s pr m (Two a (Node3 (sxy + sp) x y p))
2212 Node3 sxyz x y z -> Deep s pr m (Three a (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
2213 where !sz = size z
2214 delRebuildRightSide s pr m (Node3 _ a b c) p = let !sp = size p in case c of
2215 Node2 sxy x y -> Deep s pr m (Three a b (Node3 (sxy + sp) x y p))
2216 Node3 sxyz x y z -> Deep s pr m (Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
2217 where !sz = size z
2218
2219 delRebuildMiddle :: Sized a
2220 => Int -> Digit a -> a -> Digit a
2221 -> FingerTree a
2222 delRebuildMiddle s (One a) e sf = Deep s (Two a e) EmptyT sf
2223 delRebuildMiddle s (Two a b) e sf = Deep s (Three a b e) EmptyT sf
2224 delRebuildMiddle s (Three a b c) e sf = Deep s (Four a b c e) EmptyT sf
2225 delRebuildMiddle s (Four a b c d) e sf = Deep s (Two a b) (Single (node3 c d e)) sf
2226
2227 data DelDig a = FullDig !(Digit (Node a)) | DefectDig a
2228
2229 {-# SPECIALIZE delDigit :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Digit (Node (Elem a)) -> DelDig (Elem a) #-}
2230 {-# SPECIALIZE delDigit :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Digit (Node (Node a)) -> DelDig (Node a) #-}
2231 delDigit :: Sized a => (Int -> Node a -> Del a) -> Int -> Digit (Node a) -> DelDig a
2232 delDigit f !i (One a) = case f i a of
2233 Full a' -> FullDig $ One a'
2234 Defect e -> DefectDig e
2235 delDigit f i (Two a b)
2236 | i < sa = case f i a of
2237 Full a' -> FullDig $ Two a' b
2238 Defect e -> let !se = size e in case b of
2239 Node3 sxyz x y z -> FullDig $ Two (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)
2240 where !sx = size x
2241 Node2 sxy x y -> FullDig $ One (Node3 (se + sxy) e x y)
2242 | otherwise = case f (i - sa) b of
2243 Full b' -> FullDig $ Two a b'
2244 Defect e -> let !se = size e in case a of
2245 Node3 sxyz x y z -> FullDig $ Two (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
2246 where !sz = size z
2247 Node2 sxy x y -> FullDig $ One (Node3 (sxy + se) x y e)
2248 where sa = size a
2249 delDigit f i (Three a b c)
2250 | i < sa = case f i a of
2251 Full a' -> FullDig $ Three a' b c
2252 Defect e -> let !se = size e in case b of
2253 Node3 sxyz x y z -> FullDig $ Three (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c
2254 where !sx = size x
2255 Node2 sxy x y -> FullDig $ Two (Node3 (se + sxy) e x y) c
2256 | i < sab = case f (i - sa) b of
2257 Full b' -> FullDig $ Three a b' c
2258 Defect e -> let !se = size e in case a of
2259 Node3 sxyz x y z -> FullDig $ Three (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c
2260 where !sz = size z
2261 Node2 sxy x y -> FullDig $ Two (Node3 (sxy + se) x y e) c
2262 | otherwise = case f (i - sab) c of
2263 Full c' -> FullDig $ Three a b c'
2264 Defect e -> let !se = size e in case b of
2265 Node3 sxyz x y z -> FullDig $ Three a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
2266 where !sz = size z
2267 Node2 sxy x y -> FullDig $ Two a (Node3 (sxy + se) x y e)
2268 where sa = size a
2269 sab = sa + size b
2270 delDigit f i (Four a b c d)
2271 | i < sa = case f i a of
2272 Full a' -> FullDig $ Four a' b c d
2273 Defect e -> let !se = size e in case b of
2274 Node3 sxyz x y z -> FullDig $ Four (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c d
2275 where !sx = size x
2276 Node2 sxy x y -> FullDig $ Three (Node3 (se + sxy) e x y) c d
2277 | i < sab = case f (i - sa) b of
2278 Full b' -> FullDig $ Four a b' c d
2279 Defect e -> let !se = size e in case a of
2280 Node3 sxyz x y z -> FullDig $ Four (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c d
2281 where !sz = size z
2282 Node2 sxy x y -> FullDig $ Three (Node3 (sxy + se) x y e) c d
2283 | i < sabc = case f (i - sab) c of
2284 Full c' -> FullDig $ Four a b c' d
2285 Defect e -> let !se = size e in case b of
2286 Node3 sxyz x y z -> FullDig $ Four a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) d
2287 where !sz = size z
2288 Node2 sxy x y -> FullDig $ Three a (Node3 (sxy + se) x y e) d
2289 | otherwise = case f (i - sabc) d of
2290 Full d' -> FullDig $ Four a b c d'
2291 Defect e -> let !se = size e in case c of
2292 Node3 sxyz x y z -> FullDig $ Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
2293 where !sz = size z
2294 Node2 sxy x y -> FullDig $ Three a b (Node3 (sxy + se) x y e)
2295 where sa = size a
2296 sab = sa + size b
2297 sabc = sab + size c
2298
2299
2300 -- | /O(n)/. A generalization of 'fmap', 'mapWithIndex' takes a mapping
2301 -- function that also depends on the element's index, and applies it to every
2302 -- element in the sequence.
2303 mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
2304 mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'
2305 where
2306 {-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}
2307 {-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}
2308 mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b
2309 mapWithIndexTree _ !_s EmptyT = EmptyT
2310 mapWithIndexTree f s (Single xs) = Single $ f s xs
2311 mapWithIndexTree f s (Deep n pr m sf) =
2312 Deep n
2313 (mapWithIndexDigit f s pr)
2314 (mapWithIndexTree (mapWithIndexNode f) sPspr m)
2315 (mapWithIndexDigit f sPsprm sf)
2316 where
2317 !sPspr = s + size pr
2318 !sPsprm = sPspr + size m
2319
2320 {-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}
2321 {-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}
2322 mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b
2323 mapWithIndexDigit f !s (One a) = One (f s a)
2324 mapWithIndexDigit f s (Two a b) = Two (f s a) (f sPsa b)
2325 where
2326 !sPsa = s + size a
2327 mapWithIndexDigit f s (Three a b c) =
2328 Three (f s a) (f sPsa b) (f sPsab c)
2329 where
2330 !sPsa = s + size a
2331 !sPsab = sPsa + size b
2332 mapWithIndexDigit f s (Four a b c d) =
2333 Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)
2334 where
2335 !sPsa = s + size a
2336 !sPsab = sPsa + size b
2337 !sPsabc = sPsab + size c
2338
2339 {-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}
2340 {-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}
2341 mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b
2342 mapWithIndexNode f s (Node2 ns a b) = Node2 ns (f s a) (f sPsa b)
2343 where
2344 !sPsa = s + size a
2345 mapWithIndexNode f s (Node3 ns a b c) =
2346 Node3 ns (f s a) (f sPsa b) (f sPsab c)
2347 where
2348 !sPsa = s + size a
2349 !sPsab = sPsa + size b
2350
2351 #ifdef __GLASGOW_HASKELL__
2352 {-# NOINLINE [1] mapWithIndex #-}
2353 {-# RULES
2354 "mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =
2355 mapWithIndex (\k a -> f k (g k a)) xs
2356 "mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =
2357 mapWithIndex (\k a -> f k (g a)) xs
2358 "fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =
2359 mapWithIndex (\k a -> f (g k a)) xs
2360 #-}
2361 #endif
2362
2363
2364 -- | /O(n)/. A generalization of 'foldMap', 'foldMapWithIndex' takes a folding
2365 -- function that also depends on the element's index, and applies it to every
2366 -- element in the sequence.
2367 --
2368 -- @since 0.5.8
2369 foldMapWithIndex :: Monoid m => (Int -> a -> m) -> Seq a -> m
2370 foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs'
2371 where
2372 lift_elem :: (Int -> a -> m) -> (Int -> Elem a -> m)
2373 #if __GLASGOW_HASKELL__ >= 708
2374 lift_elem g = coerce g
2375 #else
2376 lift_elem g = \s (Elem a) -> g s a
2377 #endif
2378 {-# INLINE lift_elem #-}
2379 -- We have to specialize these functions by hand, unfortunately, because
2380 -- GHC does not specialize until *all* instances are determined.
2381 -- Although the Sized instance is known at compile time, the Monoid
2382 -- instance generally is not.
2383 foldMapWithIndexTreeE :: Monoid m => (Int -> Elem a -> m) -> Int -> FingerTree (Elem a) -> m
2384 foldMapWithIndexTreeE _ !_s EmptyT = mempty
2385 foldMapWithIndexTreeE f s (Single xs) = f s xs
2386 foldMapWithIndexTreeE f s (Deep _ pr m sf) =
2387 foldMapWithIndexDigitE f s pr <>
2388 foldMapWithIndexTreeN (foldMapWithIndexNodeE f) sPspr m <>
2389 foldMapWithIndexDigitE f sPsprm sf
2390 where
2391 !sPspr = s + size pr
2392 !sPsprm = sPspr + size m
2393
2394 foldMapWithIndexTreeN :: Monoid m => (Int -> Node a -> m) -> Int -> FingerTree (Node a) -> m
2395 foldMapWithIndexTreeN _ !_s EmptyT = mempty
2396 foldMapWithIndexTreeN f s (Single xs) = f s xs
2397 foldMapWithIndexTreeN f s (Deep _ pr m sf) =
2398 foldMapWithIndexDigitN f s pr <>
2399 foldMapWithIndexTreeN (foldMapWithIndexNodeN f) sPspr m <>
2400 foldMapWithIndexDigitN f sPsprm sf
2401 where
2402 !sPspr = s + size pr
2403 !sPsprm = sPspr + size m
2404
2405 foldMapWithIndexDigitE :: Monoid m => (Int -> Elem a -> m) -> Int -> Digit (Elem a) -> m
2406 foldMapWithIndexDigitE f i t = foldMapWithIndexDigit f i t
2407
2408 foldMapWithIndexDigitN :: Monoid m => (Int -> Node a -> m) -> Int -> Digit (Node a) -> m
2409 foldMapWithIndexDigitN f i t = foldMapWithIndexDigit f i t
2410
2411 {-# INLINE foldMapWithIndexDigit #-}
2412 foldMapWithIndexDigit :: (Monoid m, Sized a) => (Int -> a -> m) -> Int -> Digit a -> m
2413 foldMapWithIndexDigit f !s (One a) = f s a
2414 foldMapWithIndexDigit f s (Two a b) = f s a <> f sPsa b
2415 where
2416 !sPsa = s + size a
2417 foldMapWithIndexDigit f s (Three a b c) =
2418 f s a <> f sPsa b <> f sPsab c
2419 where
2420 !sPsa = s + size a
2421 !sPsab = sPsa + size b
2422 foldMapWithIndexDigit f s (Four a b c d) =
2423 f s a <> f sPsa b <> f sPsab c <> f sPsabc d
2424 where
2425 !sPsa = s + size a
2426 !sPsab = sPsa + size b
2427 !sPsabc = sPsab + size c
2428
2429 foldMapWithIndexNodeE :: Monoid m => (Int -> Elem a -> m) -> Int -> Node (Elem a) -> m
2430 foldMapWithIndexNodeE f i t = foldMapWithIndexNode f i t
2431
2432 foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m
2433 foldMapWithIndexNodeN f i t = foldMapWithIndexNode f i t
2434
2435 {-# INLINE foldMapWithIndexNode #-}
2436 foldMapWithIndexNode :: (Monoid m, Sized a) => (Int -> a -> m) -> Int -> Node a -> m
2437 foldMapWithIndexNode f !s (Node2 _ a b) = f s a <> f sPsa b
2438 where
2439 !sPsa = s + size a
2440 foldMapWithIndexNode f s (Node3 _ a b c) =
2441 f s a <> f sPsa b <> f sPsab c
2442 where
2443 !sPsa = s + size a
2444 !sPsab = sPsa + size b
2445
2446 #if __GLASGOW_HASKELL__
2447 {-# INLINABLE foldMapWithIndex #-}
2448 #endif
2449
2450 -- | 'traverseWithIndex' is a version of 'traverse' that also offers
2451 -- access to the index of each element.
2452 --
2453 -- @since 0.5.8
2454 traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
2455 traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) -> Elem <$> f' s a) 0 xs'
2456 where
2457 -- We have to specialize these functions by hand, unfortunately, because
2458 -- GHC does not specialize until *all* instances are determined.
2459 -- Although the Sized instance is known at compile time, the Applicative
2460 -- instance generally is not.
2461 traverseWithIndexTreeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> FingerTree (Elem a) -> f (FingerTree b)
2462 traverseWithIndexTreeE _ !_s EmptyT = pure EmptyT
2463 traverseWithIndexTreeE f s (Single xs) = Single <$> f s xs
2464 traverseWithIndexTreeE f s (Deep n pr m sf) =
2465 deep' n <$>
2466 traverseWithIndexDigitE f s pr <*>
2467 traverseWithIndexTreeN (traverseWithIndexNodeE f) sPspr m <*>
2468 traverseWithIndexDigitE f sPsprm sf
2469 where
2470 !sPspr = s + size pr
2471 !sPsprm = sPspr + size m
2472
2473 traverseWithIndexTreeN :: Applicative f => (Int -> Node a -> f b) -> Int -> FingerTree (Node a) -> f (FingerTree b)
2474 traverseWithIndexTreeN _ !_s EmptyT = pure EmptyT
2475 traverseWithIndexTreeN f s (Single xs) = Single <$> f s xs
2476 traverseWithIndexTreeN f s (Deep n pr m sf) =
2477 deep' n <$>
2478 traverseWithIndexDigitN f s pr <*>
2479 traverseWithIndexTreeN (traverseWithIndexNodeN f) sPspr m <*>
2480 traverseWithIndexDigitN f sPsprm sf
2481 where
2482 !sPspr = s + size pr
2483 !sPsprm = sPspr + size m
2484
2485 traverseWithIndexDigitE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Digit (Elem a) -> f (Digit b)
2486 traverseWithIndexDigitE f i t = traverseWithIndexDigit f i t
2487
2488 traverseWithIndexDigitN :: Applicative f => (Int -> Node a -> f b) -> Int -> Digit (Node a) -> f (Digit b)
2489 traverseWithIndexDigitN f i t = traverseWithIndexDigit f i t
2490
2491 {-# INLINE traverseWithIndexDigit #-}
2492 traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Digit a -> f (Digit b)
2493 traverseWithIndexDigit f !s (One a) = One <$> f s a
2494 traverseWithIndexDigit f s (Two a b) = Two <$> f s a <*> f sPsa b
2495 where
2496 !sPsa = s + size a
2497 traverseWithIndexDigit f s (Three a b c) =
2498 Three <$> f s a <*> f sPsa b <*> f sPsab c
2499 where
2500 !sPsa = s + size a
2501 !sPsab = sPsa + size b
2502 traverseWithIndexDigit f s (Four a b c d) =
2503 Four <$> f s a <*> f sPsa b <*> f sPsab c <*> f sPsabc d
2504 where
2505 !sPsa = s + size a
2506 !sPsab = sPsa + size b
2507 !sPsabc = sPsab + size c
2508
2509 traverseWithIndexNodeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Node (Elem a) -> f (Node b)
2510 traverseWithIndexNodeE f i t = traverseWithIndexNode f i t
2511
2512 traverseWithIndexNodeN :: Applicative f => (Int -> Node a -> f b) -> Int -> Node (Node a) -> f (Node b)
2513 traverseWithIndexNodeN f i t = traverseWithIndexNode f i t
2514
2515 {-# INLINE traverseWithIndexNode #-}
2516 traverseWithIndexNode :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Node a -> f (Node b)
2517 traverseWithIndexNode f !s (Node2 ns a b) = node2' ns <$> f s a <*> f sPsa b
2518 where
2519 !sPsa = s + size a
2520 traverseWithIndexNode f s (Node3 ns a b c) =
2521 node3' ns <$> f s a <*> f sPsa b <*> f sPsab c
2522 where
2523 !sPsa = s + size a
2524 !sPsab = sPsa + size b
2525
2526
2527 {-# NOINLINE [1] traverseWithIndex #-}
2528 #ifdef __GLASGOW_HASKELL__
2529 {-# RULES
2530 "travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =
2531 traverseWithIndex (\k a -> f k (g k a)) xs
2532 "travWithIndex/fmapSeq" forall f g xs . traverseWithIndex f (fmapSeq g xs) =
2533 traverseWithIndex (\k a -> f k (g a)) xs
2534 #-}
2535 #endif
2536 {-
2537 It might be nice to be able to rewrite
2538
2539 traverseWithIndex f (fromFunction i g)
2540 to
2541 replicateAWithIndex i (\k -> f k (g k))
2542 and
2543 traverse f (fromFunction i g)
2544 to
2545 replicateAWithIndex i (f . g)
2546
2547 but we don't have replicateAWithIndex as yet.
2548
2549 We might wish for a rule like
2550 "fmapSeq/travWithIndex" forall f g xs . fmapSeq f <$> traverseWithIndex g xs =
2551 traverseWithIndex (\k a -> f <$> g k a) xs
2552 Unfortunately, this rule could screw up the inliner's treatment of
2553 fmap in general, and it also relies on the arbitrary Functor being
2554 valid.
2555 -}
2556
2557
2558 -- | /O(n)/. Convert a given sequence length and a function representing that
2559 -- sequence into a sequence.
2560 fromFunction :: Int -> (Int -> a) -> Seq a
2561 fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"
2562 | len == 0 = empty
2563 | otherwise = Seq $ create (lift_elem f) 1 0 len
2564 where
2565 create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a
2566 create b{-tree_builder-} !s{-tree_size-} !i{-start_index-} trees = case trees of
2567 1 -> Single $ b i
2568 2 -> Deep (2*s) (One (b i)) EmptyT (One (b (i+s)))
2569 3 -> Deep (3*s) (createTwo i) EmptyT (One (b (i+2*s)))
2570 4 -> Deep (4*s) (createTwo i) EmptyT (createTwo (i+2*s))
2571 5 -> Deep (5*s) (createThree i) EmptyT (createTwo (i+3*s))
2572 6 -> Deep (6*s) (createThree i) EmptyT (createThree (i+3*s))
2573 _ -> case trees `quotRem` 3 of
2574 (trees', 1) -> Deep (trees*s) (createTwo i)
2575 (create mb (3*s) (i+2*s) (trees'-1))
2576 (createTwo (i+(2+3*(trees'-1))*s))
2577 (trees', 2) -> Deep (trees*s) (createThree i)
2578 (create mb (3*s) (i+3*s) (trees'-1))
2579 (createTwo (i+(3+3*(trees'-1))*s))
2580 (trees', _) -> Deep (trees*s) (createThree i)
2581 (create mb (3*s) (i+3*s) (trees'-2))
2582 (createThree (i+(3+3*(trees'-2))*s))
2583 where
2584 createTwo j = Two (b j) (b (j + s))
2585 {-# INLINE createTwo #-}
2586 createThree j = Three (b j) (b (j + s)) (b (j + 2*s))
2587 {-# INLINE createThree #-}
2588 mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))
2589 {-# INLINE mb #-}
2590
2591 lift_elem :: (Int -> a) -> (Int -> Elem a)
2592 #if __GLASGOW_HASKELL__ >= 708
2593 lift_elem g = coerce g
2594 #else
2595 lift_elem g = Elem . g
2596 #endif
2597 {-# INLINE lift_elem #-}
2598
2599 -- | /O(n)/. Create a sequence consisting of the elements of an 'Array'.
2600 -- Note that the resulting sequence elements may be evaluated lazily (as on GHC),
2601 -- so you must force the entire structure to be sure that the original array
2602 -- can be garbage-collected.
2603 fromArray :: Ix i => Array i a -> Seq a
2604 #ifdef __GLASGOW_HASKELL__
2605 fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)
2606 where
2607 -- The following definition uses (Ix i) constraing, which is needed for the
2608 -- other fromArray definition.
2609 _ = Data.Array.rangeSize (Data.Array.bounds a)
2610 #else
2611 fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)
2612 #endif
2613
2614 -- Splitting
2615
2616 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
2617 -- If @i@ is negative, @'take' i s@ yields the empty sequence.
2618 -- If the sequence contains fewer than @i@ elements, the whole sequence
2619 -- is returned.
2620 take :: Int -> Seq a -> Seq a
2621 take i xs@(Seq t)
2622 -- See note on unsigned arithmetic in splitAt
2623 | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =
2624 Seq (takeTreeE i t)
2625 | i <= 0 = empty
2626 | otherwise = xs
2627
2628 takeTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)
2629 takeTreeE !_i EmptyT = EmptyT
2630 takeTreeE i t@(Single _)
2631 | i <= 0 = EmptyT
2632 | otherwise = t
2633 takeTreeE i (Deep s pr m sf)
2634 | i < spr = takePrefixE i pr
2635 | i < spm = case takeTreeN im m of
2636 ml :*: xs -> takeMiddleE (im - size ml) spr pr ml xs
2637 | otherwise = takeSuffixE (i - spm) s pr m sf
2638 where
2639 spr = size pr
2640 spm = spr + size m
2641 im = i - spr
2642
2643 takeTreeN :: Int -> FingerTree (Node a) -> StrictPair (FingerTree (Node a)) (Node a)
2644 takeTreeN !_i EmptyT = error "takeTreeN of empty tree"
2645 takeTreeN _i (Single x) = EmptyT :*: x
2646 takeTreeN i (Deep s pr m sf)
2647 | i < spr = takePrefixN i pr
2648 | i < spm = case takeTreeN im m of
2649 ml :*: xs -> takeMiddleN (im - size ml) spr pr ml xs
2650 | otherwise = takeSuffixN (i - spm) s pr m sf where
2651 spr = size pr
2652 spm = spr + size m
2653 im = i - spr
2654
2655 takeMiddleN :: Int -> Int
2656 -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a)
2657 -> StrictPair (FingerTree (Node a)) (Node a)
2658 takeMiddleN i spr pr ml (Node2 _ a b)
2659 | i < sa = pullR sprml pr ml :*: a
2660 | otherwise = Deep sprmla pr ml (One a) :*: b
2661 where
2662 sa = size a
2663 sprml = spr + size ml
2664 sprmla = sa + sprml
2665 takeMiddleN i spr pr ml (Node3 _ a b c)
2666 | i < sa = pullR sprml pr ml :*: a
2667 | i < sab = Deep sprmla pr ml (One a) :*: b
2668 | otherwise = Deep sprmlab pr ml (Two a b) :*: c
2669 where
2670 sa = size a
2671 sab = sa + size b
2672 sprml = spr + size ml
2673 sprmla = sa + sprml
2674 sprmlab = sprmla + size b
2675
2676 takeMiddleE :: Int -> Int
2677 -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a)
2678 -> FingerTree (Elem a)
2679 takeMiddleE i spr pr ml (Node2 _ a _)
2680 | i < 1 = pullR sprml pr ml
2681 | otherwise = Deep sprmla pr ml (One a)
2682 where
2683 sprml = spr + size ml
2684 sprmla = 1 + sprml
2685 takeMiddleE i spr pr ml (Node3 _ a b _)
2686 | i < 1 = pullR sprml pr ml
2687 | i < 2 = Deep sprmla pr ml (One a)
2688 | otherwise = Deep sprmlab pr ml (Two a b)
2689 where
2690 sprml = spr + size ml
2691 sprmla = 1 + sprml
2692 sprmlab = sprmla + 1
2693
2694 takePrefixE :: Int -> Digit (Elem a) -> FingerTree (Elem a)
2695 takePrefixE !_i (One _) = EmptyT
2696 takePrefixE i (Two a _)
2697 | i < 1 = EmptyT
2698 | otherwise = Single a
2699 takePrefixE i (Three a b _)
2700 | i < 1 = EmptyT
2701 | i < 2 = Single a
2702 | otherwise = Deep 2 (One a) EmptyT (One b)
2703 takePrefixE i (Four a b c _)
2704 | i < 1 = EmptyT
2705 | i < 2 = Single a
2706 | i < 3 = Deep 2 (One a) EmptyT (One b)
2707 | otherwise = Deep 3 (Two a b) EmptyT (One c)
2708
2709 takePrefixN :: Int -> Digit (Node a)
2710 -> StrictPair (FingerTree (Node a)) (Node a)
2711 takePrefixN !_i (One a) = EmptyT :*: a
2712 takePrefixN i (Two a b)
2713 | i < sa = EmptyT :*: a
2714 | otherwise = Single a :*: b
2715 where
2716 sa = size a
2717 takePrefixN i (Three a b c)
2718 | i < sa = EmptyT :*: a
2719 | i < sab = Single a :*: b
2720 | otherwise = Deep sab (One a) EmptyT (One b) :*: c
2721 where
2722 sa = size a
2723 sab = sa + size b
2724 takePrefixN i (Four a b c d)
2725 | i < sa = EmptyT :*: a
2726 | i < sab = Single a :*: b
2727 | i < sabc = Deep sab (One a) EmptyT (One b) :*: c
2728 | otherwise = Deep sabc (Two a b) EmptyT (One c) :*: d
2729 where
2730 sa = size a
2731 sab = sa + size b
2732 sabc = sab + size c
2733
2734 takeSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
2735 FingerTree (Elem a)
2736 takeSuffixE !_i !s pr m (One _) = pullR (s - 1) pr m
2737 takeSuffixE i s pr m (Two a _)
2738 | i < 1 = pullR (s - 2) pr m
2739 | otherwise = Deep (s - 1) pr m (One a)
2740 takeSuffixE i s pr m (Three a b _)
2741 | i < 1 = pullR (s - 3) pr m
2742 | i < 2 = Deep (s - 2) pr m (One a)
2743 | otherwise = Deep (s - 1) pr m (Two a b)
2744 takeSuffixE i s pr m (Four a b c _)
2745 | i < 1 = pullR (s - 4) pr m
2746 | i < 2 = Deep (s - 3) pr m (One a)
2747 | i < 3 = Deep (s - 2) pr m (Two a b)
2748 | otherwise = Deep (s - 1) pr m (Three a b c)
2749
2750 takeSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
2751 StrictPair (FingerTree (Node a)) (Node a)
2752 takeSuffixN !_i !s pr m (One a) = pullR (s - size a) pr m :*: a
2753 takeSuffixN i s pr m (Two a b)
2754 | i < sa = pullR (s - sa - size b) pr m :*: a
2755 | otherwise = Deep (s - size b) pr m (One a) :*: b
2756 where
2757 sa = size a
2758 takeSuffixN i s pr m (Three a b c)
2759 | i < sa = pullR (s - sab - size c) pr m :*: a
2760 | i < sab = Deep (s - size b - size c) pr m (One a) :*: b
2761 | otherwise = Deep (s - size c) pr m (Two a b) :*: c
2762 where
2763 sa = size a
2764 sab = sa + size b
2765 takeSuffixN i s pr m (Four a b c d)
2766 | i < sa = pullR (s - sa - sbcd) pr m :*: a
2767 | i < sab = Deep (s - sbcd) pr m (One a) :*: b
2768 | i < sabc = Deep (s - scd) pr m (Two a b) :*: c
2769 | otherwise = Deep (s - sd) pr m (Three a b c) :*: d
2770 where
2771 sa = size a
2772 sab = sa + size b
2773 sabc = sab + size c
2774 sd = size d
2775 scd = size c + sd
2776 sbcd = size b + scd
2777
2778 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
2779 -- If @i@ is negative, @'drop' i s@ yields the whole sequence.
2780 -- If the sequence contains fewer than @i@ elements, the empty sequence
2781 -- is returned.
2782 drop :: Int -> Seq a -> Seq a
2783 drop i xs@(Seq t)
2784 -- See note on unsigned arithmetic in splitAt
2785 | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =
2786 Seq (takeTreeER (length xs - i) t)
2787 | i <= 0 = xs
2788 | otherwise = empty
2789
2790 -- We implement `drop` using a "take from the rear" strategy. There's no
2791 -- particular technical reason for this; it just lets us reuse the arithmetic
2792 -- from `take` (which itself reuses the arithmetic from `splitAt`) instead of
2793 -- figuring it out from scratch and ending up with lots of off-by-one errors.
2794 takeTreeER :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)
2795 takeTreeER !_i EmptyT = EmptyT
2796 takeTreeER i t@(Single _)
2797 | i <= 0 = EmptyT
2798 | otherwise = t
2799 takeTreeER i (Deep s pr m sf)
2800 | i < ssf = takeSuffixER i sf
2801 | i < ssm = case takeTreeNR im m of
2802 xs :*: mr -> takeMiddleER (im - size mr) ssf xs mr sf
2803 | otherwise = takePrefixER (i - ssm) s pr m sf
2804 where
2805 ssf = size sf
2806 ssm = ssf + size m
2807 im = i - ssf
2808
2809 takeTreeNR :: Int -> FingerTree (Node a) -> StrictPair (Node a) (FingerTree (Node a))
2810 takeTreeNR !_i EmptyT = error "takeTreeNR of empty tree"
2811 takeTreeNR _i (Single x) = x :*: EmptyT
2812 takeTreeNR i (Deep s pr m sf)
2813 | i < ssf = takeSuffixNR i sf
2814 | i < ssm = case takeTreeNR im m of
2815 xs :*: mr -> takeMiddleNR (im - size mr) ssf xs mr sf
2816 | otherwise = takePrefixNR (i - ssm) s pr m sf where
2817 ssf = size sf
2818 ssm = ssf + size m
2819 im = i - ssf
2820
2821 takeMiddleNR :: Int -> Int
2822 -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)
2823 -> StrictPair (Node a) (FingerTree (Node a))
2824 takeMiddleNR i ssf (Node2 _ a b) mr sf
2825 | i < sb = b :*: pullL ssfmr mr sf
2826 | otherwise = a :*: Deep ssfmrb (One b) mr sf
2827 where
2828 sb = size b
2829 ssfmr = ssf + size mr
2830 ssfmrb = sb + ssfmr
2831 takeMiddleNR i ssf (Node3 _ a b c) mr sf
2832 | i < sc = c :*: pullL ssfmr mr sf
2833 | i < sbc = b :*: Deep ssfmrc (One c) mr sf
2834 | otherwise = a :*: Deep ssfmrbc (Two b c) mr sf
2835 where
2836 sc = size c
2837 sbc = sc + size b
2838 ssfmr = ssf + size mr
2839 ssfmrc = sc + ssfmr
2840 ssfmrbc = ssfmrc + size b
2841
2842 takeMiddleER :: Int -> Int
2843 -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)
2844 -> FingerTree (Elem a)
2845 takeMiddleER i ssf (Node2 _ _ b) mr sf
2846 | i < 1 = pullL ssfmr mr sf
2847 | otherwise = Deep ssfmrb (One b) mr sf
2848 where
2849 ssfmr = ssf + size mr
2850 ssfmrb = 1 + ssfmr
2851 takeMiddleER i ssf (Node3 _ _ b c) mr sf
2852 | i < 1 = pullL ssfmr mr sf
2853 | i < 2 = Deep ssfmrc (One c) mr sf
2854 | otherwise = Deep ssfmrbc (Two b c) mr sf
2855 where
2856 ssfmr = ssf + size mr
2857 ssfmrc = 1 + ssfmr
2858 ssfmrbc = ssfmr + 2
2859
2860 takeSuffixER :: Int -> Digit (Elem a) -> FingerTree (Elem a)
2861 takeSuffixER !_i (One _) = EmptyT
2862 takeSuffixER i (Two _ b)
2863 | i < 1 = EmptyT
2864 | otherwise = Single b
2865 takeSuffixER i (Three _ b c)
2866 | i < 1 = EmptyT
2867 | i < 2 = Single c
2868 | otherwise = Deep 2 (One b) EmptyT (One c)
2869 takeSuffixER i (Four _ b c d)
2870 | i < 1 = EmptyT
2871 | i < 2 = Single d
2872 | i < 3 = Deep 2 (One c) EmptyT (One d)
2873 | otherwise = Deep 3 (Two b c) EmptyT (One d)
2874
2875 takeSuffixNR :: Int -> Digit (Node a)
2876 -> StrictPair (Node a) (FingerTree (Node a))
2877 takeSuffixNR !_i (One a) = a :*: EmptyT
2878 takeSuffixNR i (Two a b)
2879 | i < sb = b :*: EmptyT
2880 | otherwise = a :*: Single b
2881 where
2882 sb = size b
2883 takeSuffixNR i (Three a b c)
2884 | i < sc = c :*: EmptyT
2885 | i < sbc = b :*: Single c
2886 | otherwise = a :*: Deep sbc (One b) EmptyT (One c)
2887 where
2888 sc = size c
2889 sbc = sc + size b
2890 takeSuffixNR i (Four a b c d)
2891 | i < sd = d :*: EmptyT
2892 | i < scd = c :*: Single d
2893 | i < sbcd = b :*: Deep scd (One c) EmptyT (One d)
2894 | otherwise = a :*: Deep sbcd (Two b c) EmptyT (One d)
2895 where
2896 sd = size d
2897 scd = sd + size c
2898 sbcd = scd + size b
2899
2900 takePrefixER :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
2901 FingerTree (Elem a)
2902 takePrefixER !_i !s (One _) m sf = pullL (s - 1) m sf
2903 takePrefixER i s (Two _ b) m sf
2904 | i < 1 = pullL (s - 2) m sf
2905 | otherwise = Deep (s - 1) (One b) m sf
2906 takePrefixER i s (Three _ b c) m sf
2907 | i < 1 = pullL (s - 3) m sf
2908 | i < 2 = Deep (s - 2) (One c) m sf
2909 | otherwise = Deep (s - 1) (Two b c) m sf
2910 takePrefixER i s (Four _ b c d) m sf
2911 | i < 1 = pullL (s - 4) m sf
2912 | i < 2 = Deep (s - 3) (One d) m sf
2913 | i < 3 = Deep (s - 2) (Two c d) m sf
2914 | otherwise = Deep (s - 1) (Three b c d) m sf
2915
2916 takePrefixNR :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
2917 StrictPair (Node a) (FingerTree (Node a))
2918 takePrefixNR !_i !s (One a) m sf = a :*: pullL (s - size a) m sf
2919 takePrefixNR i s (Two a b) m sf
2920 | i < sb = b :*: pullL (s - sb - size a) m sf
2921 | otherwise = a :*: Deep (s - size a) (One b) m sf
2922 where
2923 sb = size b
2924 takePrefixNR i s (Three a b c) m sf
2925 | i < sc = c :*: pullL (s - sbc - size a) m sf
2926 | i < sbc = b :*: Deep (s - size b - size a) (One c) m sf
2927 | otherwise = a :*: Deep (s - size a) (Two b c) m sf
2928 where
2929 sc = size c
2930 sbc = sc + size b
2931 takePrefixNR i s (Four a b c d) m sf
2932 | i < sd = d :*: pullL (s - sd - sabc) m sf
2933 | i < scd = c :*: Deep (s - sabc) (One d) m sf
2934 | i < sbcd = b :*: Deep (s - sab) (Two c d) m sf
2935 | otherwise = a :*: Deep (s - sa) (Three b c d) m sf
2936 where
2937 sa = size a
2938 sab = sa + size b
2939 sabc = sab + size c
2940 sd = size d
2941 scd = size c + sd
2942 sbcd = size b + scd
2943
2944 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
2945 -- @'splitAt' i s = ('take' i s, 'drop' i s)@.
2946 splitAt :: Int -> Seq a -> (Seq a, Seq a)
2947 splitAt i xs@(Seq t)
2948 -- We use an unsigned comparison to make the common case
2949 -- faster. This only works because our representation of
2950 -- sizes as (signed) Ints gives us a free high bit to play
2951 -- with. Note also that there's no sharing to lose in the
2952 -- case that the length is 0.
2953 | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =
2954 case splitTreeE i t of
2955 l :*: r -> (Seq l, Seq r)
2956 | i <= 0 = (empty, xs)
2957 | otherwise = (xs, empty)
2958
2959 -- | /O(log(min(i,n-i))) A version of 'splitAt' that does not attempt to
2960 -- enhance sharing when the split point is less than or equal to 0, and that
2961 -- gives completely wrong answers when the split point is at least the length
2962 -- of the sequence, unless the sequence is a singleton. This is used to
2963 -- implement zipWith and chunksOf, which are extremely sensitive to the cost of
2964 -- splitting very short sequences. There is just enough of a speed increase to
2965 -- make this worth the trouble.
2966 uncheckedSplitAt :: Int -> Seq a -> (Seq a, Seq a)
2967 uncheckedSplitAt i (Seq xs) = case splitTreeE i xs of
2968 l :*: r -> (Seq l, Seq r)
2969
2970 data Split a = Split !(FingerTree (Node a)) !(Node a) !(FingerTree (Node a))
2971 #if TESTING
2972 deriving Show
2973 #endif
2974
2975 splitTreeE :: Int -> FingerTree (Elem a) -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
2976 splitTreeE !_i EmptyT = EmptyT :*: EmptyT
2977 splitTreeE i t@(Single _)
2978 | i <= 0 = EmptyT :*: t
2979 | otherwise = t :*: EmptyT
2980 splitTreeE i (Deep s pr m sf)
2981 | i < spr = splitPrefixE i s pr m sf
2982 | i < spm = case splitTreeN im m of
2983 Split ml xs mr -> splitMiddleE (im - size ml) s spr pr ml xs mr sf
2984 | otherwise = splitSuffixE (i - spm) s pr m sf
2985 where
2986 spr = size pr
2987 spm = spr + size m
2988 im = i - spr
2989
2990 splitTreeN :: Int -> FingerTree (Node a) -> Split a
2991 splitTreeN !_i EmptyT = error "splitTreeN of empty tree"
2992 splitTreeN _i (Single x) = Split EmptyT x EmptyT
2993 splitTreeN i (Deep s pr m sf)
2994 | i < spr = splitPrefixN i s pr m sf
2995 | i < spm = case splitTreeN im m of
2996 Split ml xs mr -> splitMiddleN (im - size ml) s spr pr ml xs mr sf
2997 | otherwise = splitSuffixN (i - spm) s pr m sf where
2998 spr = size pr
2999 spm = spr + size m
3000 im = i - spr
3001
3002 splitMiddleN :: Int -> Int -> Int
3003 -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)
3004 -> Split a
3005 splitMiddleN i s spr pr ml (Node2 _ a b) mr sf
3006 | i < sa = Split (pullR sprml pr ml) a (Deep (s - sprmla) (One b) mr sf)
3007 | otherwise = Split (Deep sprmla pr ml (One a)) b (pullL (s - sprmla - size b) mr sf)
3008 where
3009 sa = size a
3010 sprml = spr + size ml
3011 sprmla = sa + sprml
3012 splitMiddleN i s spr pr ml (Node3 _ a b c) mr sf
3013 | i < sa = Split (pullR sprml pr ml) a (Deep (s - sprmla) (Two b c) mr sf)
3014 | i < sab = Split (Deep sprmla pr ml (One a)) b (Deep (s - sprmlab) (One c) mr sf)
3015 | otherwise = Split (Deep sprmlab pr ml (Two a b)) c (pullL (s - sprmlab - size c) mr sf)
3016 where
3017 sa = size a
3018 sab = sa + size b
3019 sprml = spr + size ml
3020 sprmla = sa + sprml
3021 sprmlab = sprmla + size b
3022
3023 splitMiddleE :: Int -> Int -> Int
3024 -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)
3025 -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
3026 splitMiddleE i s spr pr ml (Node2 _ a b) mr sf
3027 | i < 1 = pullR sprml pr ml :*: Deep (s - sprml) (Two a b) mr sf
3028 | otherwise = Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (One b) mr sf
3029 where
3030 sprml = spr + size ml
3031 sprmla = 1 + sprml
3032 splitMiddleE i s spr pr ml (Node3 _ a b c) mr sf = case i of
3033 0 -> pullR sprml pr ml :*: Deep (s - sprml) (Three a b c) mr sf
3034 1 -> Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (Two b c) mr sf
3035 _ -> Deep sprmlab pr ml (Two a b) :*: Deep (s - sprmlab) (One c) mr sf
3036 where
3037 sprml = spr + size ml
3038 sprmla = 1 + sprml
3039 sprmlab = sprmla + 1
3040
3041 splitPrefixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
3042 StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
3043 splitPrefixE !_i !s (One a) m sf = EmptyT :*: Deep s (One a) m sf
3044 splitPrefixE i s (Two a b) m sf = case i of
3045 0 -> EmptyT :*: Deep s (Two a b) m sf
3046 _ -> Single a :*: Deep (s - 1) (One b) m sf
3047 splitPrefixE i s (Three a b c) m sf = case i of
3048 0 -> EmptyT :*: Deep s (Three a b c) m sf
3049 1 -> Single a :*: Deep (s - 1) (Two b c) m sf
3050 _ -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (One c) m sf
3051 splitPrefixE i s (Four a b c d) m sf = case i of
3052 0 -> EmptyT :*: Deep s (Four a b c d) m sf
3053 1 -> Single a :*: Deep (s - 1) (Three b c d) m sf
3054 2 -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (Two c d) m sf
3055 _ -> Deep 3 (Two a b) EmptyT (One c) :*: Deep (s - 3) (One d) m sf
3056
3057 splitPrefixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
3058 Split a
3059 splitPrefixN !_i !s (One a) m sf = Split EmptyT a (pullL (s - size a) m sf)
3060 splitPrefixN i s (Two a b) m sf
3061 | i < sa = Split EmptyT a (Deep (s - sa) (One b) m sf)
3062 | otherwise = Split (Single a) b (pullL (s - sa - size b) m sf)
3063 where
3064 sa = size a
3065 splitPrefixN i s (Three a b c) m sf
3066 | i < sa = Split EmptyT a (Deep (s - sa) (Two b c) m sf)
3067 | i < sab = Split (Single a) b (Deep (s - sab) (One c) m sf)
3068 | otherwise = Split (Deep sab (One a) EmptyT (One b)) c (pullL (s - sab - size c) m sf)
3069 where
3070 sa = size a
3071 sab = sa + size b
3072 splitPrefixN i s (Four a b c d) m sf
3073 | i < sa = Split EmptyT a $ Deep (s - sa) (Three b c d) m sf
3074 | i < sab = Split (Single a) b $ Deep (s - sab) (Two c d) m sf
3075 | i < sabc = Split (Deep sab (One a) EmptyT (One b)) c $ Deep (s - sabc) (One d) m sf
3076 | otherwise = Split (Deep sabc (Two a b) EmptyT (One c)) d $ pullL (s - sabc - size d) m sf
3077 where
3078 sa = size a
3079 sab = sa + size b
3080 sabc = sab + size c
3081
3082 splitSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
3083 StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
3084 splitSuffixE !_i !s pr m (One a) = pullR (s - 1) pr m :*: Single a
3085 splitSuffixE i s pr m (Two a b) = case i of
3086 0 -> pullR (s - 2) pr m :*: Deep 2 (One a) EmptyT (One b)
3087 _ -> Deep (s - 1) pr m (One a) :*: Single b
3088 splitSuffixE i s pr m (Three a b c) = case i of
3089 0 -> pullR (s - 3) pr m :*: Deep 3 (Two a b) EmptyT (One c)
3090 1 -> Deep (s - 2) pr m (One a) :*: Deep 2 (One b) EmptyT (One c)
3091 _ -> Deep (s - 1) pr m (Two a b) :*: Single c
3092 splitSuffixE i s pr m (Four a b c d) = case i of
3093 0 -> pullR (s - 4) pr m :*: Deep 4 (Two a b) EmptyT (Two c d)
3094 1 -> Deep (s - 3) pr m (One a) :*: Deep 3 (Two b c) EmptyT (One d)
3095 2 -> Deep (s - 2) pr m (Two a b) :*: Deep 2 (One c) EmptyT (One d)
3096 _ -> Deep (s - 1) pr m (Three a b c) :*: Single d
3097
3098 splitSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
3099 Split a
3100 splitSuffixN !_i !s pr m (One a) = Split (pullR (s - size a) pr m) a EmptyT
3101 splitSuffixN i s pr m (Two a b)
3102 | i < sa = Split (pullR (s - sa - size b) pr m) a (Single b)
3103 | otherwise = Split (Deep (s - size b) pr m (One a)) b EmptyT
3104 where
3105 sa = size a
3106 splitSuffixN i s pr m (Three a b c)
3107 | i < sa = Split (pullR (s - sab - size c) pr m) a (deep (One b) EmptyT (One c))
3108 | i < sab = Split (Deep (s - size b - size c) pr m (One a)) b (Single c)
3109 | otherwise = Split (Deep (s - size c) pr m (Two a b)) c EmptyT
3110 where
3111 sa = size a
3112 sab = sa + size b
3113 splitSuffixN i s pr m (Four a b c d)
3114 | i < sa = Split (pullR (s - sa - sbcd) pr m) a (Deep sbcd (Two b c) EmptyT (One d))
3115 | i < sab = Split (Deep (s - sbcd) pr m (One a)) b (Deep scd (One c) EmptyT (One d))
3116 | i < sabc = Split (Deep (s - scd) pr m (Two a b)) c (Single d)
3117 | otherwise = Split (Deep (s - sd) pr m (Three a b c)) d EmptyT
3118 where
3119 sa = size a
3120 sab = sa + size b
3121 sabc = sab + size c
3122 sd = size d
3123 scd = size c + sd
3124 sbcd = size b + scd
3125
3126 -- | /O(n)/. @chunksOf n xs@ splits @xs@ into chunks of size @n>0@.
3127 -- If @n@ does not divide the length of @xs@ evenly, then the last element
3128 -- of the result will be short.
3129 chunksOf :: Int -> Seq a -> Seq (Seq a)
3130 chunksOf n xs | n <= 0 =
3131 if null xs
3132 then empty
3133 else error "chunksOf: A non-empty sequence can only be broken up into positively-sized chunks."
3134 chunksOf 1 s = fmap singleton s
3135 chunksOf n s = splitMap (uncheckedSplitAt . (*n)) const most (replicate numReps ())
3136 >< if null end then empty else singleton end
3137 where
3138 (numReps, endLength) = length s `quotRem` n
3139 (most, end) = splitAt (length s - endLength) s
3140
3141 -- | /O(n)/. Returns a sequence of all suffixes of this sequence,
3142 -- longest first. For example,
3143 --
3144 -- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
3145 --
3146 -- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating
3147 -- every suffix in the sequence takes /O(n)/ due to sharing.
3148 tails :: Seq a -> Seq (Seq a)
3149 tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
3150
3151 -- | /O(n)/. Returns a sequence of all prefixes of this sequence,
3152 -- shortest first. For example,
3153 --
3154 -- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
3155 --
3156 -- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating
3157 -- every prefix in the sequence takes /O(n)/ due to sharing.
3158 inits :: Seq a -> Seq (Seq a)
3159 inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
3160
3161 -- This implementation of tails (and, analogously, inits) has the
3162 -- following algorithmic advantages:
3163 -- Evaluating each tail in the sequence takes linear total time,
3164 -- which is better than we could say for
3165 -- @fromList [drop n xs | n <- [0..length xs]]@.
3166 -- Evaluating any individual tail takes logarithmic time, which is
3167 -- better than we can say for either
3168 -- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
3169 --
3170 -- Moreover, if we actually look at every tail in the sequence, the
3171 -- following benchmarks demonstrate that this implementation is modestly
3172 -- faster than any of the above:
3173 --
3174 -- Times (ms)
3175 -- min mean +/-sd median max
3176 -- Seq.tails: 21.986 24.961 10.169 22.417 86.485
3177 -- scanr: 85.392 87.942 2.488 87.425 100.217
3178 -- iterateN: 29.952 31.245 1.574 30.412 37.268
3179 --
3180 -- The algorithm for tails (and, analogously, inits) is as follows:
3181 --
3182 -- A Node in the FingerTree of tails is constructed by evaluating the
3183 -- corresponding tail of the FingerTree of Nodes, considering the first
3184 -- Node in this tail, and constructing a Node in which each tail of this
3185 -- Node is made to be the prefix of the remaining tree. This ends up
3186 -- working quite elegantly, as the remainder of the tail of the FingerTree
3187 -- of Nodes becomes the middle of a new tail, the suffix of the Node is
3188 -- the prefix, and the suffix of the original tree is retained.
3189 --
3190 -- In particular, evaluating the /i/th tail involves making as
3191 -- many partial evaluations as the Node depth of the /i/th element.
3192 -- In addition, when we evaluate the /i/th tail, and we also evaluate
3193 -- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,
3194 -- each of those /m/ evaluations are shared between the computation of
3195 -- the /i/th and /j/th tails.
3196 --
3197 -- wasserman.louis@gmail.com, 7/16/09
3198
3199 tailsDigit :: Digit a -> Digit (Digit a)
3200 tailsDigit (One a) = One (One a)
3201 tailsDigit (Two a b) = Two (Two a b) (One b)
3202 tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
3203 tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
3204
3205 initsDigit :: Digit a -> Digit (Digit a)
3206 initsDigit (One a) = One (One a)
3207 initsDigit (Two a b) = Two (One a) (Two a b)
3208 initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
3209 initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
3210
3211 tailsNode :: Node a -> Node (Digit a)
3212 tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
3213 tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
3214
3215 initsNode :: Node a -> Node (Digit a)
3216 initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
3217 initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
3218
3219 {-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
3220 {-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
3221 -- | Given a function to apply to tails of a tree, applies that function
3222 -- to every tail of the specified tree.
3223 tailsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b
3224 tailsTree _ EmptyT = EmptyT
3225 tailsTree f (Single x) = Single (f (Single x))
3226 tailsTree f (Deep n pr m sf) =
3227 Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
3228 (tailsTree f' m)
3229 (fmap (f . digitToTree) (tailsDigit sf))
3230 where
3231 f' ms = let ConsLTree node m' = viewLTree ms in
3232 fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
3233
3234 {-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
3235 {-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
3236 -- | Given a function to apply to inits of a tree, applies that function
3237 -- to every init of the specified tree.
3238 initsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b
3239 initsTree _ EmptyT = EmptyT
3240 initsTree f (Single x) = Single (f (Single x))
3241 initsTree f (Deep n pr m sf) =
3242 Deep n (fmap (f . digitToTree) (initsDigit pr))
3243 (initsTree f' m)
3244 (fmap (f . deep pr m) (initsDigit sf))
3245 where
3246 f' ms = let SnocRTree m' node = viewRTree ms in
3247 fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
3248
3249 {-# INLINE foldlWithIndex #-}
3250 -- | 'foldlWithIndex' is a version of 'foldl' that also provides access
3251 -- to the index of each element.
3252 foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
3253 foldlWithIndex f z xs = foldl (\ g x !i -> f (g (i - 1)) i x) (const z) xs (length xs - 1)
3254
3255 {-# INLINE foldrWithIndex #-}
3256 -- | 'foldrWithIndex' is a version of 'foldr' that also provides access
3257 -- to the index of each element.
3258 foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
3259 foldrWithIndex f z xs = foldr (\ x g !i -> f i x (g (i+1))) (const z) xs 0
3260
3261 {-# INLINE listToMaybe' #-}
3262 -- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.
3263 listToMaybe' :: [a] -> Maybe a
3264 listToMaybe' = foldr (\ x _ -> Just x) Nothing
3265
3266 -- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied
3267 -- to a predicate @p@ and a sequence @xs@, returns the longest prefix
3268 -- (possibly empty) of @xs@ of elements that satisfy @p@.
3269 takeWhileL :: (a -> Bool) -> Seq a -> Seq a
3270 takeWhileL p = fst . spanl p
3271
3272 -- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied
3273 -- to a predicate @p@ and a sequence @xs@, returns the longest suffix
3274 -- (possibly empty) of @xs@ of elements that satisfy @p@.
3275 --
3276 -- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.
3277 takeWhileR :: (a -> Bool) -> Seq a -> Seq a
3278 takeWhileR p = fst . spanr p
3279
3280 -- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns
3281 -- the suffix remaining after @'takeWhileL' p xs@.
3282 dropWhileL :: (a -> Bool) -> Seq a -> Seq a
3283 dropWhileL p = snd . spanl p
3284
3285 -- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns
3286 -- the prefix remaining after @'takeWhileR' p xs@.
3287 --
3288 -- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.
3289 dropWhileR :: (a -> Bool) -> Seq a -> Seq a
3290 dropWhileR p = snd . spanr p
3291
3292 -- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to
3293 -- a predicate @p@ and a sequence @xs@, returns a pair whose first
3294 -- element is the longest prefix (possibly empty) of @xs@ of elements that
3295 -- satisfy @p@ and the second element is the remainder of the sequence.
3296 spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
3297 spanl p = breakl (not . p)
3298
3299 -- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a
3300 -- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element
3301 -- is the longest /suffix/ (possibly empty) of @xs@ of elements that
3302 -- satisfy @p@ and the second element is the remainder of the sequence.
3303 spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
3304 spanr p = breakr (not . p)
3305
3306 {-# INLINE breakl #-}
3307 -- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a
3308 -- predicate @p@ and a sequence @xs@, returns a pair whose first element
3309 -- is the longest prefix (possibly empty) of @xs@ of elements that
3310 -- /do not satisfy/ @p@ and the second element is the remainder of
3311 -- the sequence.
3312 --
3313 -- @'breakl' p@ is equivalent to @'spanl' (not . p)@.
3314 breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
3315 breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
3316
3317 {-# INLINE breakr #-}
3318 -- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.
3319 breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
3320 breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
3321 where flipPair (x, y) = (y, x)
3322
3323 -- | /O(n)/. The 'partition' function takes a predicate @p@ and a
3324 -- sequence @xs@ and returns sequences of those elements which do and
3325 -- do not satisfy the predicate.
3326 partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
3327 partition p = foldl part (empty, empty)
3328 where
3329 part (xs, ys) x
3330 | p x = (xs |> x, ys)
3331 | otherwise = (xs, ys |> x)
3332
3333 -- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence
3334 -- @xs@ and returns a sequence of those elements which satisfy the
3335 -- predicate.
3336 filter :: (a -> Bool) -> Seq a -> Seq a
3337 filter p = foldl' (\ xs x -> if p x then xs |> x else xs) empty
3338
3339 -- Indexing sequences
3340
3341 -- | 'elemIndexL' finds the leftmost index of the specified element,
3342 -- if it is present, and otherwise 'Nothing'.
3343 elemIndexL :: Eq a => a -> Seq a -> Maybe Int
3344 elemIndexL x = findIndexL (x ==)
3345
3346 -- | 'elemIndexR' finds the rightmost index of the specified element,
3347 -- if it is present, and otherwise 'Nothing'.
3348 elemIndexR :: Eq a => a -> Seq a -> Maybe Int
3349 elemIndexR x = findIndexR (x ==)
3350
3351 -- | 'elemIndicesL' finds the indices of the specified element, from
3352 -- left to right (i.e. in ascending order).
3353 elemIndicesL :: Eq a => a -> Seq a -> [Int]
3354 elemIndicesL x = findIndicesL (x ==)
3355
3356 -- | 'elemIndicesR' finds the indices of the specified element, from
3357 -- right to left (i.e. in descending order).
3358 elemIndicesR :: Eq a => a -> Seq a -> [Int]
3359 elemIndicesR x = findIndicesR (x ==)
3360
3361 -- | @'findIndexL' p xs@ finds the index of the leftmost element that
3362 -- satisfies @p@, if any exist.
3363 findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
3364 findIndexL p = listToMaybe' . findIndicesL p
3365
3366 -- | @'findIndexR' p xs@ finds the index of the rightmost element that
3367 -- satisfies @p@, if any exist.
3368 findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
3369 findIndexR p = listToMaybe' . findIndicesR p