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