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