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