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