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