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