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