Use Safe Haskell for GHC >= 7.2
[packages/containers.git] / Data / Sequence.hs
1 #if __GLASGOW_HASKELL__ >= 701
2 {-# LANGUAGE Trustworthy #-}
3 #endif
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : Data.Sequence
7 -- Copyright : (c) Ross Paterson 2005
8 -- (c) Louis Wasserman 2009
9 -- License : BSD-style
10 -- Maintainer : libraries@haskell.org
11 -- Stability : experimental
12 -- Portability : portable
13 --
14 -- General purpose finite sequences.
15 -- Apart from being finite and having strict operations, sequences
16 -- also differ from lists in supporting a wider variety of operations
17 -- efficiently.
18 --
19 -- An amortized running time is given for each operation, with /n/ referring
20 -- to the length of the sequence and /i/ being the integral index used by
21 -- some operations. These bounds hold even in a persistent (shared) setting.
22 --
23 -- The implementation uses 2-3 finger trees annotated with sizes,
24 -- as described in section 4.2 of
25 --
26 -- * Ralf Hinze and Ross Paterson,
27 -- \"Finger trees: a simple general-purpose data structure\",
28 -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
29 -- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
30 --
31 -- /Note/: Many of these operations have the same names as similar
32 -- operations on lists in the "Prelude". The ambiguity may be resolved
33 -- using either qualification or the @hiding@ clause.
34 --
35 -----------------------------------------------------------------------------
36
37 module Data.Sequence (
38 Seq,
39 -- * Construction
40 empty, -- :: Seq a
41 singleton, -- :: a -> Seq a
42 (<|), -- :: a -> Seq a -> Seq a
43 (|>), -- :: Seq a -> a -> Seq a
44 (><), -- :: Seq a -> Seq a -> Seq a
45 fromList, -- :: [a] -> Seq a
46 -- ** Repetition
47 replicate, -- :: Int -> a -> Seq a
48 replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)
49 replicateM, -- :: Monad m => Int -> m a -> m (Seq a)
50 -- ** Iterative construction
51 iterateN, -- :: Int -> (a -> a) -> a -> Seq a
52 unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a
53 unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a
54 -- * Deconstruction
55 -- | Additional functions for deconstructing sequences are available
56 -- via the 'Foldable' instance of 'Seq'.
57
58 -- ** Queries
59 null, -- :: Seq a -> Bool
60 length, -- :: Seq a -> Int
61 -- ** Views
62 ViewL(..),
63 viewl, -- :: Seq a -> ViewL a
64 ViewR(..),
65 viewr, -- :: Seq a -> ViewR a
66 -- * Scans
67 scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a
68 scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a
69 scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b
70 scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a
71 -- * Sublists
72 tails, -- :: Seq a -> Seq (Seq a)
73 inits, -- :: Seq a -> Seq (Seq a)
74 -- ** Sequential searches
75 takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
76 takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
77 dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a
78 dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a
79 spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
80 spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
81 breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
82 breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
83 partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
84 filter, -- :: (a -> Bool) -> Seq a -> Seq a
85 -- * Sorting
86 sort, -- :: Ord a => Seq a -> Seq a
87 sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
88 unstableSort, -- :: Ord a => Seq a -> Seq a
89 unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a
90 -- * Indexing
91 index, -- :: Seq a -> Int -> a
92 adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
93 update, -- :: Int -> a -> Seq a -> Seq a
94 take, -- :: Int -> Seq a -> Seq a
95 drop, -- :: Int -> Seq a -> Seq a
96 splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
97 -- ** Indexing with predicates
98 -- | These functions perform sequential searches from the left
99 -- or right ends of the sequence, returning indices of matching
100 -- elements.
101 elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int
102 elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]
103 elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int
104 elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]
105 findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int
106 findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]
107 findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int
108 findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]
109 -- * Folds
110 -- | General folds are available via the 'Foldable' instance of 'Seq'.
111 foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
112 foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
113 -- * Transformations
114 mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b
115 reverse, -- :: Seq a -> Seq a
116 -- ** Zips
117 zip, -- :: Seq a -> Seq b -> Seq (a, b)
118 zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
119 zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
120 zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
121 zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
122 zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
123 #if TESTING
124 valid,
125 #endif
126 ) where
127
128 import Prelude hiding (
129 Functor(..),
130 null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
131 scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
132 takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
133 import qualified Data.List (foldl', sortBy)
134 import Control.Applicative (Applicative(..), (<$>), WrappedMonad(..), liftA, liftA2, liftA3)
135 import Control.Monad (MonadPlus(..), ap)
136 import Data.Monoid (Monoid(..))
137 import Data.Functor (Functor(..))
138 import Data.Foldable
139 import Data.Traversable
140 import Data.Typeable
141
142 #ifdef __GLASGOW_HASKELL__
143 import GHC.Exts (build)
144 import Text.Read (Lexeme(Ident), lexP, parens, prec,
145 readPrec, readListPrec, readListPrecDefault)
146 import Data.Data
147 #endif
148
149 #if TESTING
150 import qualified Data.List (zipWith)
151 import Test.QuickCheck hiding ((><))
152 #endif
153
154 infixr 5 `consTree`
155 infixl 5 `snocTree`
156
157 infixr 5 ><
158 infixr 5 <|, :<
159 infixl 5 |>, :>
160
161 class Sized a where
162 size :: a -> Int
163
164 -- | General-purpose finite sequences.
165 newtype Seq a = Seq (FingerTree (Elem a))
166
167 instance Functor Seq where
168 fmap f (Seq xs) = Seq (fmap (fmap f) xs)
169 #ifdef __GLASGOW_HASKELL__
170 x <$ s = replicate (length s) x
171 #endif
172
173 instance Foldable Seq where
174 foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
175 foldl f z (Seq xs) = foldl (foldl f) z xs
176
177 foldr1 f (Seq xs) = getElem (foldr1 f' xs)
178 where f' (Elem x) (Elem y) = Elem (f x y)
179
180 foldl1 f (Seq xs) = getElem (foldl1 f' xs)
181 where f' (Elem x) (Elem y) = Elem (f x y)
182
183 instance Traversable Seq where
184 traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
185
186 instance Monad Seq where
187 return = singleton
188 xs >>= f = foldl' add empty xs
189 where add ys x = ys >< f x
190
191 instance MonadPlus Seq where
192 mzero = empty
193 mplus = (><)
194
195 instance Eq a => Eq (Seq a) where
196 xs == ys = length xs == length ys && toList xs == toList ys
197
198 instance Ord a => Ord (Seq a) where
199 compare xs ys = compare (toList xs) (toList ys)
200
201 #if TESTING
202 instance Show a => Show (Seq a) where
203 showsPrec p (Seq x) = showsPrec p x
204 #else
205 instance Show a => Show (Seq a) where
206 showsPrec p xs = showParen (p > 10) $
207 showString "fromList " . shows (toList xs)
208 #endif
209
210 instance Read a => Read (Seq a) where
211 #ifdef __GLASGOW_HASKELL__
212 readPrec = parens $ prec 10 $ do
213 Ident "fromList" <- lexP
214 xs <- readPrec
215 return (fromList xs)
216
217 readListPrec = readListPrecDefault
218 #else
219 readsPrec p = readParen (p > 10) $ \ r -> do
220 ("fromList",s) <- lex r
221 (xs,t) <- reads s
222 return (fromList xs,t)
223 #endif
224
225 instance Monoid (Seq a) where
226 mempty = empty
227 mappend = (><)
228
229 #include "Typeable.h"
230 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
231
232 #if __GLASGOW_HASKELL__
233 instance Data a => Data (Seq a) where
234 gfoldl f z s = case viewl s of
235 EmptyL -> z empty
236 x :< xs -> z (<|) `f` x `f` xs
237
238 gunfold k z c = case constrIndex c of
239 1 -> z empty
240 2 -> k (k (z (<|)))
241 _ -> error "gunfold"
242
243 toConstr xs
244 | null xs = emptyConstr
245 | otherwise = consConstr
246
247 dataTypeOf _ = seqDataType
248
249 dataCast1 f = gcast1 f
250
251 emptyConstr, consConstr :: Constr
252 emptyConstr = mkConstr seqDataType "empty" [] Prefix
253 consConstr = mkConstr seqDataType "<|" [] Infix
254
255 seqDataType :: DataType
256 seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
257 #endif
258
259 -- Finger trees
260
261 data FingerTree a
262 = Empty
263 | Single a
264 | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
265 #if TESTING
266 deriving Show
267 #endif
268
269 instance Sized a => Sized (FingerTree a) where
270 {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
271 {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
272 size Empty = 0
273 size (Single x) = size x
274 size (Deep v _ _ _) = v
275
276 instance Foldable FingerTree where
277 foldr _ z Empty = z
278 foldr f z (Single x) = x `f` z
279 foldr f z (Deep _ pr m sf) =
280 foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
281
282 foldl _ z Empty = z
283 foldl f z (Single x) = z `f` x
284 foldl f z (Deep _ pr m sf) =
285 foldl f (foldl (foldl f) (foldl f z pr) m) sf
286
287 foldr1 _ Empty = error "foldr1: empty sequence"
288 foldr1 _ (Single x) = x
289 foldr1 f (Deep _ pr m sf) =
290 foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
291
292 foldl1 _ Empty = error "foldl1: empty sequence"
293 foldl1 _ (Single x) = x
294 foldl1 f (Deep _ pr m sf) =
295 foldl f (foldl (foldl f) (foldl1 f pr) m) sf
296
297 instance Functor FingerTree where
298 fmap _ Empty = Empty
299 fmap f (Single x) = Single (f x)
300 fmap f (Deep v pr m sf) =
301 Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
302
303 instance Traversable FingerTree where
304 traverse _ Empty = pure Empty
305 traverse f (Single x) = Single <$> f x
306 traverse f (Deep v pr m sf) =
307 Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
308 traverse f sf
309
310 {-# INLINE deep #-}
311 {-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
312 {-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
313 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
314 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
315
316 {-# INLINE pullL #-}
317 pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a
318 pullL s m sf = case viewLTree m of
319 Nothing2 -> digitToTree' s sf
320 Just2 pr m' -> Deep s (nodeToDigit pr) m' sf
321
322 {-# INLINE pullR #-}
323 pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a
324 pullR s pr m = case viewRTree m of
325 Nothing2 -> digitToTree' s pr
326 Just2 m' sf -> Deep s pr m' (nodeToDigit sf)
327
328 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
329 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
330 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
331 deepL Nothing m sf = pullL (size m + size sf) m sf
332 deepL (Just pr) m sf = deep pr m sf
333
334 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
335 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
336 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
337 deepR pr m Nothing = pullR (size m + size pr) pr m
338 deepR pr m (Just sf) = deep pr m sf
339
340 -- Digits
341
342 data Digit a
343 = One a
344 | Two a a
345 | Three a a a
346 | Four a a a a
347 #if TESTING
348 deriving Show
349 #endif
350
351 instance Foldable Digit where
352 foldr f z (One a) = a `f` z
353 foldr f z (Two a b) = a `f` (b `f` z)
354 foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
355 foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
356
357 foldl f z (One a) = z `f` a
358 foldl f z (Two a b) = (z `f` a) `f` b
359 foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
360 foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
361
362 foldr1 _ (One a) = a
363 foldr1 f (Two a b) = a `f` b
364 foldr1 f (Three a b c) = a `f` (b `f` c)
365 foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
366
367 foldl1 _ (One a) = a
368 foldl1 f (Two a b) = a `f` b
369 foldl1 f (Three a b c) = (a `f` b) `f` c
370 foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
371
372 instance Functor Digit where
373 {-# INLINE fmap #-}
374 fmap f (One a) = One (f a)
375 fmap f (Two a b) = Two (f a) (f b)
376 fmap f (Three a b c) = Three (f a) (f b) (f c)
377 fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
378
379 instance Traversable Digit where
380 {-# INLINE traverse #-}
381 traverse f (One a) = One <$> f a
382 traverse f (Two a b) = Two <$> f a <*> f b
383 traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
384 traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
385
386 instance Sized a => Sized (Digit a) where
387 {-# INLINE size #-}
388 size = foldl1 (+) . fmap size
389
390 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
391 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
392 digitToTree :: Sized a => Digit a -> FingerTree a
393 digitToTree (One a) = Single a
394 digitToTree (Two a b) = deep (One a) Empty (One b)
395 digitToTree (Three a b c) = deep (Two a b) Empty (One c)
396 digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
397
398 -- | Given the size of a digit and the digit itself, efficiently converts
399 -- it to a FingerTree.
400 digitToTree' :: Int -> Digit a -> FingerTree a
401 digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)
402 digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)
403 digitToTree' n (Two a b) = Deep n (One a) Empty (One b)
404 digitToTree' n (One a) = n `seq` Single a
405
406 -- Nodes
407
408 data Node a
409 = Node2 {-# UNPACK #-} !Int a a
410 | Node3 {-# UNPACK #-} !Int a a a
411 #if TESTING
412 deriving Show
413 #endif
414
415 instance Foldable Node where
416 foldr f z (Node2 _ a b) = a `f` (b `f` z)
417 foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
418
419 foldl f z (Node2 _ a b) = (z `f` a) `f` b
420 foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
421
422 instance Functor Node where
423 {-# INLINE fmap #-}
424 fmap f (Node2 v a b) = Node2 v (f a) (f b)
425 fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
426
427 instance Traversable Node where
428 {-# INLINE traverse #-}
429 traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
430 traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
431
432 instance Sized (Node a) where
433 size (Node2 v _ _) = v
434 size (Node3 v _ _ _) = v
435
436 {-# INLINE node2 #-}
437 {-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
438 {-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
439 node2 :: Sized a => a -> a -> Node a
440 node2 a b = Node2 (size a + size b) a b
441
442 {-# INLINE node3 #-}
443 {-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
444 {-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
445 node3 :: Sized a => a -> a -> a -> Node a
446 node3 a b c = Node3 (size a + size b + size c) a b c
447
448 nodeToDigit :: Node a -> Digit a
449 nodeToDigit (Node2 _ a b) = Two a b
450 nodeToDigit (Node3 _ a b c) = Three a b c
451
452 -- Elements
453
454 newtype Elem a = Elem { getElem :: a }
455
456 instance Sized (Elem a) where
457 size _ = 1
458
459 instance Functor Elem where
460 fmap f (Elem x) = Elem (f x)
461
462 instance Foldable Elem where
463 foldr f z (Elem x) = f x z
464 foldl f z (Elem x) = f z x
465
466 instance Traversable Elem where
467 traverse f (Elem x) = Elem <$> f x
468
469 #ifdef TESTING
470 instance (Show a) => Show (Elem a) where
471 showsPrec p (Elem x) = showsPrec p x
472 #endif
473
474 -------------------------------------------------------
475 -- Applicative construction
476 -------------------------------------------------------
477
478 newtype Id a = Id {runId :: a}
479
480 instance Functor Id where
481 fmap f (Id x) = Id (f x)
482
483 instance Monad Id where
484 return = Id
485 m >>= k = k (runId m)
486
487 instance Applicative Id where
488 pure = return
489 (<*>) = ap
490
491 -- | This is essentially a clone of Control.Monad.State.Strict.
492 newtype State s a = State {runState :: s -> (s, a)}
493
494 instance Functor (State s) where
495 fmap = liftA
496
497 instance Monad (State s) where
498 {-# INLINE return #-}
499 {-# INLINE (>>=) #-}
500 return x = State $ \ s -> (s, x)
501 m >>= k = State $ \ s -> case runState m s of
502 (s', x) -> runState (k x) s'
503
504 instance Applicative (State s) where
505 pure = return
506 (<*>) = ap
507
508 execState :: State s a -> s -> a
509 execState m x = snd (runState m x)
510
511 -- | A helper method: a strict version of mapAccumL.
512 mapAccumL' :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)
513 mapAccumL' f s t = runState (traverse (State . flip f) t) s
514
515 -- | 'applicativeTree' takes an Applicative-wrapped construction of a
516 -- piece of a FingerTree, assumed to always have the same size (which
517 -- is put in the second argument), and replicates it as many times as
518 -- specified. This is a generalization of 'replicateA', which itself
519 -- is a generalization of many Data.Sequence methods.
520 {-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
521 {-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-}
522 -- Special note: the Id specialization automatically does node sharing,
523 -- reducing memory usage of the resulting tree to /O(log n)/.
524 applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
525 applicativeTree n mSize m = mSize `seq` case n of
526 0 -> pure Empty
527 1 -> liftA Single m
528 2 -> deepA one emptyTree one
529 3 -> deepA two emptyTree one
530 4 -> deepA two emptyTree two
531 5 -> deepA three emptyTree two
532 6 -> deepA three emptyTree three
533 7 -> deepA four emptyTree three
534 8 -> deepA four emptyTree four
535 _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of
536 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three
537 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three
538 _ -> deepA four (applicativeTree (q - 2) mSize' n3) four
539 where
540 one = liftA One m
541 two = liftA2 Two m m
542 three = liftA3 Three m m m
543 four = liftA3 Four m m m <*> m
544 deepA = liftA3 (Deep (n * mSize))
545 mSize' = 3 * mSize
546 n3 = liftA3 (Node3 mSize') m m m
547 emptyTree = pure Empty
548
549 ------------------------------------------------------------------------
550 -- Construction
551 ------------------------------------------------------------------------
552
553 -- | /O(1)/. The empty sequence.
554 empty :: Seq a
555 empty = Seq Empty
556
557 -- | /O(1)/. A singleton sequence.
558 singleton :: a -> Seq a
559 singleton x = Seq (Single (Elem x))
560
561 -- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.
562 replicate :: Int -> a -> Seq a
563 replicate n x
564 | n >= 0 = runId (replicateA n (Id x))
565 | otherwise = error "replicate takes a nonnegative integer argument"
566
567 -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
568 -- /O(log n)/ calls to '<*>' and 'pure'.
569 --
570 -- > replicateA n x = sequenceA (replicate n x)
571 replicateA :: Applicative f => Int -> f a -> f (Seq a)
572 replicateA n x
573 | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
574 | otherwise = error "replicateA takes a nonnegative integer argument"
575
576 -- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
577 --
578 -- > replicateM n x = sequence (replicate n x)
579 replicateM :: Monad m => Int -> m a -> m (Seq a)
580 replicateM n x
581 | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))
582 | otherwise = error "replicateM takes a nonnegative integer argument"
583
584 -- | /O(1)/. Add an element to the left end of a sequence.
585 -- Mnemonic: a triangle with the single element at the pointy end.
586 (<|) :: a -> Seq a -> Seq a
587 x <| Seq xs = Seq (Elem x `consTree` xs)
588
589 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
590 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
591 consTree :: Sized a => a -> FingerTree a -> FingerTree a
592 consTree a Empty = Single a
593 consTree a (Single b) = deep (One a) Empty (One b)
594 consTree a (Deep s (Four b c d e) m sf) = m `seq`
595 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
596 consTree a (Deep s (Three b c d) m sf) =
597 Deep (size a + s) (Four a b c d) m sf
598 consTree a (Deep s (Two b c) m sf) =
599 Deep (size a + s) (Three a b c) m sf
600 consTree a (Deep s (One b) m sf) =
601 Deep (size a + s) (Two a b) m sf
602
603 -- | /O(1)/. Add an element to the right end of a sequence.
604 -- Mnemonic: a triangle with the single element at the pointy end.
605 (|>) :: Seq a -> a -> Seq a
606 Seq xs |> x = Seq (xs `snocTree` Elem x)
607
608 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
609 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
610 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
611 snocTree Empty a = Single a
612 snocTree (Single a) b = deep (One a) Empty (One b)
613 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
614 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
615 snocTree (Deep s pr m (Three a b c)) d =
616 Deep (s + size d) pr m (Four a b c d)
617 snocTree (Deep s pr m (Two a b)) c =
618 Deep (s + size c) pr m (Three a b c)
619 snocTree (Deep s pr m (One a)) b =
620 Deep (s + size b) pr m (Two a b)
621
622 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
623 (><) :: Seq a -> Seq a -> Seq a
624 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
625
626 -- The appendTree/addDigits gunk below is machine generated
627
628 appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
629 appendTree0 Empty xs =
630 xs
631 appendTree0 xs Empty =
632 xs
633 appendTree0 (Single x) xs =
634 x `consTree` xs
635 appendTree0 xs (Single x) =
636 xs `snocTree` x
637 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
638 Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
639
640 addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
641 addDigits0 m1 (One a) (One b) m2 =
642 appendTree1 m1 (node2 a b) m2
643 addDigits0 m1 (One a) (Two b c) m2 =
644 appendTree1 m1 (node3 a b c) m2
645 addDigits0 m1 (One a) (Three b c d) m2 =
646 appendTree2 m1 (node2 a b) (node2 c d) m2
647 addDigits0 m1 (One a) (Four b c d e) m2 =
648 appendTree2 m1 (node3 a b c) (node2 d e) m2
649 addDigits0 m1 (Two a b) (One c) m2 =
650 appendTree1 m1 (node3 a b c) m2
651 addDigits0 m1 (Two a b) (Two c d) m2 =
652 appendTree2 m1 (node2 a b) (node2 c d) m2
653 addDigits0 m1 (Two a b) (Three c d e) m2 =
654 appendTree2 m1 (node3 a b c) (node2 d e) m2
655 addDigits0 m1 (Two a b) (Four c d e f) m2 =
656 appendTree2 m1 (node3 a b c) (node3 d e f) m2
657 addDigits0 m1 (Three a b c) (One d) m2 =
658 appendTree2 m1 (node2 a b) (node2 c d) m2
659 addDigits0 m1 (Three a b c) (Two d e) m2 =
660 appendTree2 m1 (node3 a b c) (node2 d e) m2
661 addDigits0 m1 (Three a b c) (Three d e f) m2 =
662 appendTree2 m1 (node3 a b c) (node3 d e f) m2
663 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
664 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
665 addDigits0 m1 (Four a b c d) (One e) m2 =
666 appendTree2 m1 (node3 a b c) (node2 d e) m2
667 addDigits0 m1 (Four a b c d) (Two e f) m2 =
668 appendTree2 m1 (node3 a b c) (node3 d e f) m2
669 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
670 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
671 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
672 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
673
674 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
675 appendTree1 Empty a xs =
676 a `consTree` xs
677 appendTree1 xs a Empty =
678 xs `snocTree` a
679 appendTree1 (Single x) a xs =
680 x `consTree` a `consTree` xs
681 appendTree1 xs a (Single x) =
682 xs `snocTree` a `snocTree` x
683 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
684 Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
685
686 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
687 addDigits1 m1 (One a) b (One c) m2 =
688 appendTree1 m1 (node3 a b c) m2
689 addDigits1 m1 (One a) b (Two c d) m2 =
690 appendTree2 m1 (node2 a b) (node2 c d) m2
691 addDigits1 m1 (One a) b (Three c d e) m2 =
692 appendTree2 m1 (node3 a b c) (node2 d e) m2
693 addDigits1 m1 (One a) b (Four c d e f) m2 =
694 appendTree2 m1 (node3 a b c) (node3 d e f) m2
695 addDigits1 m1 (Two a b) c (One d) m2 =
696 appendTree2 m1 (node2 a b) (node2 c d) m2
697 addDigits1 m1 (Two a b) c (Two d e) m2 =
698 appendTree2 m1 (node3 a b c) (node2 d e) m2
699 addDigits1 m1 (Two a b) c (Three d e f) m2 =
700 appendTree2 m1 (node3 a b c) (node3 d e f) m2
701 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
702 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
703 addDigits1 m1 (Three a b c) d (One e) m2 =
704 appendTree2 m1 (node3 a b c) (node2 d e) m2
705 addDigits1 m1 (Three a b c) d (Two e f) m2 =
706 appendTree2 m1 (node3 a b c) (node3 d e f) m2
707 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
708 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
709 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
710 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
711 addDigits1 m1 (Four a b c d) e (One f) m2 =
712 appendTree2 m1 (node3 a b c) (node3 d e f) m2
713 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
714 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
715 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
716 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
717 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
718 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
719
720 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
721 appendTree2 Empty a b xs =
722 a `consTree` b `consTree` xs
723 appendTree2 xs a b Empty =
724 xs `snocTree` a `snocTree` b
725 appendTree2 (Single x) a b xs =
726 x `consTree` a `consTree` b `consTree` xs
727 appendTree2 xs a b (Single x) =
728 xs `snocTree` a `snocTree` b `snocTree` x
729 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
730 Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
731
732 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
733 addDigits2 m1 (One a) b c (One d) m2 =
734 appendTree2 m1 (node2 a b) (node2 c d) m2
735 addDigits2 m1 (One a) b c (Two d e) m2 =
736 appendTree2 m1 (node3 a b c) (node2 d e) m2
737 addDigits2 m1 (One a) b c (Three d e f) m2 =
738 appendTree2 m1 (node3 a b c) (node3 d e f) m2
739 addDigits2 m1 (One a) b c (Four d e f g) m2 =
740 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
741 addDigits2 m1 (Two a b) c d (One e) m2 =
742 appendTree2 m1 (node3 a b c) (node2 d e) m2
743 addDigits2 m1 (Two a b) c d (Two e f) m2 =
744 appendTree2 m1 (node3 a b c) (node3 d e f) m2
745 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
746 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
747 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
748 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
749 addDigits2 m1 (Three a b c) d e (One f) m2 =
750 appendTree2 m1 (node3 a b c) (node3 d e f) m2
751 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
752 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
753 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
754 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
755 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
756 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
757 addDigits2 m1 (Four a b c d) e f (One g) m2 =
758 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
759 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
760 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
761 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
762 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
763 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
764 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
765
766 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
767 appendTree3 Empty a b c xs =
768 a `consTree` b `consTree` c `consTree` xs
769 appendTree3 xs a b c Empty =
770 xs `snocTree` a `snocTree` b `snocTree` c
771 appendTree3 (Single x) a b c xs =
772 x `consTree` a `consTree` b `consTree` c `consTree` xs
773 appendTree3 xs a b c (Single x) =
774 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
775 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
776 Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
777
778 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))
779 addDigits3 m1 (One a) b c d (One e) m2 =
780 appendTree2 m1 (node3 a b c) (node2 d e) m2
781 addDigits3 m1 (One a) b c d (Two e f) m2 =
782 appendTree2 m1 (node3 a b c) (node3 d e f) m2
783 addDigits3 m1 (One a) b c d (Three e f g) m2 =
784 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
785 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
786 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
787 addDigits3 m1 (Two a b) c d e (One f) m2 =
788 appendTree2 m1 (node3 a b c) (node3 d e f) m2
789 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
790 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
791 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
792 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
793 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
794 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
795 addDigits3 m1 (Three a b c) d e f (One g) m2 =
796 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
797 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
798 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
799 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
800 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
801 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
802 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
803 addDigits3 m1 (Four a b c d) e f g (One h) m2 =
804 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
805 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
806 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
807 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
808 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
809 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
810 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
811
812 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
813 appendTree4 Empty a b c d xs =
814 a `consTree` b `consTree` c `consTree` d `consTree` xs
815 appendTree4 xs a b c d Empty =
816 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
817 appendTree4 (Single x) a b c d xs =
818 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
819 appendTree4 xs a b c d (Single x) =
820 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
821 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
822 Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
823
824 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))
825 addDigits4 m1 (One a) b c d e (One f) m2 =
826 appendTree2 m1 (node3 a b c) (node3 d e f) m2
827 addDigits4 m1 (One a) b c d e (Two f g) m2 =
828 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
829 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
830 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
831 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
832 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
833 addDigits4 m1 (Two a b) c d e f (One g) m2 =
834 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
835 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
836 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
837 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
838 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
839 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
840 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
841 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
842 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
843 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
844 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
845 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
846 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
847 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
848 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
849 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
850 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
851 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
852 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
853 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
854 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
855 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
856 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
857
858 -- | Builds a sequence from a seed value. Takes time linear in the
859 -- number of generated elements. /WARNING:/ If the number of generated
860 -- elements is infinite, this method will not terminate.
861 unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
862 unfoldr f = unfoldr' empty
863 -- uses tail recursion rather than, for instance, the List implementation.
864 where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)
865
866 -- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.
867 unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
868 unfoldl f = unfoldl' empty
869 where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)
870
871 -- | /O(n)/. Constructs a sequence by repeated application of a function
872 -- to a seed value.
873 --
874 -- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))
875 iterateN :: Int -> (a -> a) -> a -> Seq a
876 iterateN n f x
877 | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
878 | otherwise = error "iterateN takes a nonnegative integer argument"
879
880 ------------------------------------------------------------------------
881 -- Deconstruction
882 ------------------------------------------------------------------------
883
884 -- | /O(1)/. Is this the empty sequence?
885 null :: Seq a -> Bool
886 null (Seq Empty) = True
887 null _ = False
888
889 -- | /O(1)/. The number of elements in the sequence.
890 length :: Seq a -> Int
891 length (Seq xs) = size xs
892
893 -- Views
894
895 data Maybe2 a b = Nothing2 | Just2 a b
896
897 -- | View of the left end of a sequence.
898 data ViewL a
899 = EmptyL -- ^ empty sequence
900 | a :< Seq a -- ^ leftmost element and the rest of the sequence
901 #if __GLASGOW_HASKELL__
902 deriving (Eq, Ord, Show, Read, Data)
903 #else
904 deriving (Eq, Ord, Show, Read)
905 #endif
906
907 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
908
909 instance Functor ViewL where
910 {-# INLINE fmap #-}
911 fmap _ EmptyL = EmptyL
912 fmap f (x :< xs) = f x :< fmap f xs
913
914 instance Foldable ViewL where
915 foldr _ z EmptyL = z
916 foldr f z (x :< xs) = f x (foldr f z xs)
917
918 foldl _ z EmptyL = z
919 foldl f z (x :< xs) = foldl f (f z x) xs
920
921 foldl1 _ EmptyL = error "foldl1: empty view"
922 foldl1 f (x :< xs) = foldl f x xs
923
924 instance Traversable ViewL where
925 traverse _ EmptyL = pure EmptyL
926 traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
927
928 -- | /O(1)/. Analyse the left end of a sequence.
929 viewl :: Seq a -> ViewL a
930 viewl (Seq xs) = case viewLTree xs of
931 Nothing2 -> EmptyL
932 Just2 (Elem x) xs' -> x :< Seq xs'
933
934 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
935 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
936 viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
937 viewLTree Empty = Nothing2
938 viewLTree (Single a) = Just2 a Empty
939 viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)
940 viewLTree (Deep s (Two a b) m sf) =
941 Just2 a (Deep (s - size a) (One b) m sf)
942 viewLTree (Deep s (Three a b c) m sf) =
943 Just2 a (Deep (s - size a) (Two b c) m sf)
944 viewLTree (Deep s (Four a b c d) m sf) =
945 Just2 a (Deep (s - size a) (Three b c d) m sf)
946
947 -- | View of the right end of a sequence.
948 data ViewR a
949 = EmptyR -- ^ empty sequence
950 | Seq a :> a -- ^ the sequence minus the rightmost element,
951 -- and the rightmost element
952 #if __GLASGOW_HASKELL__
953 deriving (Eq, Ord, Show, Read, Data)
954 #else
955 deriving (Eq, Ord, Show, Read)
956 #endif
957
958 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
959
960 instance Functor ViewR where
961 {-# INLINE fmap #-}
962 fmap _ EmptyR = EmptyR
963 fmap f (xs :> x) = fmap f xs :> f x
964
965 instance Foldable ViewR where
966 foldr _ z EmptyR = z
967 foldr f z (xs :> x) = foldr f (f x z) xs
968
969 foldl _ z EmptyR = z
970 foldl f z (xs :> x) = foldl f z xs `f` x
971
972 foldr1 _ EmptyR = error "foldr1: empty view"
973 foldr1 f (xs :> x) = foldr f x xs
974
975 instance Traversable ViewR where
976 traverse _ EmptyR = pure EmptyR
977 traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
978
979 -- | /O(1)/. Analyse the right end of a sequence.
980 viewr :: Seq a -> ViewR a
981 viewr (Seq xs) = case viewRTree xs of
982 Nothing2 -> EmptyR
983 Just2 xs' (Elem x) -> Seq xs' :> x
984
985 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
986 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
987 viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
988 viewRTree Empty = Nothing2
989 viewRTree (Single z) = Just2 Empty z
990 viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z
991 viewRTree (Deep s pr m (Two y z)) =
992 Just2 (Deep (s - size z) pr m (One y)) z
993 viewRTree (Deep s pr m (Three x y z)) =
994 Just2 (Deep (s - size z) pr m (Two x y)) z
995 viewRTree (Deep s pr m (Four w x y z)) =
996 Just2 (Deep (s - size z) pr m (Three w x y)) z
997
998 ------------------------------------------------------------------------
999 -- Scans
1000 --
1001 -- These are not particularly complex applications of the Traversable
1002 -- functor, though making the correspondence with Data.List exact
1003 -- requires the use of (<|) and (|>).
1004 --
1005 -- Note that save for the single (<|) or (|>), we maintain the original
1006 -- structure of the Seq, not having to do any restructuring of our own.
1007 --
1008 -- wasserman.louis@gmail.com, 5/23/09
1009 ------------------------------------------------------------------------
1010
1011 -- | 'scanl' is similar to 'foldl', but returns a sequence of reduced
1012 -- values from the left:
1013 --
1014 -- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]
1015 scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
1016 scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
1017
1018 -- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
1019 --
1020 -- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]
1021 scanl1 :: (a -> a -> a) -> Seq a -> Seq a
1022 scanl1 f xs = case viewl xs of
1023 EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
1024 x :< xs' -> scanl f x xs'
1025
1026 -- | 'scanr' is the right-to-left dual of 'scanl'.
1027 scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
1028 scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
1029
1030 -- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
1031 scanr1 :: (a -> a -> a) -> Seq a -> Seq a
1032 scanr1 f xs = case viewr xs of
1033 EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
1034 xs' :> x -> scanr f x xs'
1035
1036 -- Indexing
1037
1038 -- | /O(log(min(i,n-i)))/. The element at the specified position,
1039 -- counting from 0. The argument should thus be a non-negative
1040 -- integer less than the size of the sequence.
1041 -- If the position is out of range, 'index' fails with an error.
1042 index :: Seq a -> Int -> a
1043 index (Seq xs) i
1044 | 0 <= i && i < size xs = case lookupTree i xs of
1045 Place _ (Elem x) -> x
1046 | otherwise = error "index out of bounds"
1047
1048 data Place a = Place {-# UNPACK #-} !Int a
1049 #if TESTING
1050 deriving Show
1051 #endif
1052
1053 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
1054 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
1055 lookupTree :: Sized a => Int -> FingerTree a -> Place a
1056 lookupTree _ Empty = error "lookupTree of empty tree"
1057 lookupTree i (Single x) = Place i x
1058 lookupTree i (Deep _ pr m sf)
1059 | i < spr = lookupDigit i pr
1060 | i < spm = case lookupTree (i - spr) m of
1061 Place i' xs -> lookupNode i' xs
1062 | otherwise = lookupDigit (i - spm) sf
1063 where
1064 spr = size pr
1065 spm = spr + size m
1066
1067 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
1068 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
1069 lookupNode :: Sized a => Int -> Node a -> Place a
1070 lookupNode i (Node2 _ a b)
1071 | i < sa = Place i a
1072 | otherwise = Place (i - sa) b
1073 where
1074 sa = size a
1075 lookupNode i (Node3 _ a b c)
1076 | i < sa = Place i a
1077 | i < sab = Place (i - sa) b
1078 | otherwise = Place (i - sab) c
1079 where
1080 sa = size a
1081 sab = sa + size b
1082
1083 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
1084 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
1085 lookupDigit :: Sized a => Int -> Digit a -> Place a
1086 lookupDigit i (One a) = Place i a
1087 lookupDigit i (Two a b)
1088 | i < sa = Place i a
1089 | otherwise = Place (i - sa) b
1090 where
1091 sa = size a
1092 lookupDigit i (Three a b c)
1093 | i < sa = Place i a
1094 | i < sab = Place (i - sa) b
1095 | otherwise = Place (i - sab) c
1096 where
1097 sa = size a
1098 sab = sa + size b
1099 lookupDigit i (Four a b c d)
1100 | i < sa = Place i a
1101 | i < sab = Place (i - sa) b
1102 | i < sabc = Place (i - sab) c
1103 | otherwise = Place (i - sabc) d
1104 where
1105 sa = size a
1106 sab = sa + size b
1107 sabc = sab + size c
1108
1109 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position.
1110 -- If the position is out of range, the original sequence is returned.
1111 update :: Int -> a -> Seq a -> Seq a
1112 update i x = adjust (const x) i
1113
1114 -- | /O(log(min(i,n-i)))/. Update the element at the specified position.
1115 -- If the position is out of range, the original sequence is returned.
1116 adjust :: (a -> a) -> Int -> Seq a -> Seq a
1117 adjust f i (Seq xs)
1118 | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
1119 | otherwise = Seq xs
1120
1121 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
1122 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
1123 adjustTree :: Sized a => (Int -> a -> a) ->
1124 Int -> FingerTree a -> FingerTree a
1125 adjustTree _ _ Empty = error "adjustTree of empty tree"
1126 adjustTree f i (Single x) = Single (f i x)
1127 adjustTree f i (Deep s pr m sf)
1128 | i < spr = Deep s (adjustDigit f i pr) m sf
1129 | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
1130 | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
1131 where
1132 spr = size pr
1133 spm = spr + size m
1134
1135 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
1136 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
1137 adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
1138 adjustNode f i (Node2 s a b)
1139 | i < sa = Node2 s (f i a) b
1140 | otherwise = Node2 s a (f (i - sa) b)
1141 where
1142 sa = size a
1143 adjustNode f i (Node3 s a b c)
1144 | i < sa = Node3 s (f i a) b c
1145 | i < sab = Node3 s a (f (i - sa) b) c
1146 | otherwise = Node3 s a b (f (i - sab) c)
1147 where
1148 sa = size a
1149 sab = sa + size b
1150
1151 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
1152 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
1153 adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
1154 adjustDigit f i (One a) = One (f i a)
1155 adjustDigit f i (Two a b)
1156 | i < sa = Two (f i a) b
1157 | otherwise = Two a (f (i - sa) b)
1158 where
1159 sa = size a
1160 adjustDigit f i (Three a b c)
1161 | i < sa = Three (f i a) b c
1162 | i < sab = Three a (f (i - sa) b) c
1163 | otherwise = Three a b (f (i - sab) c)
1164 where
1165 sa = size a
1166 sab = sa + size b
1167 adjustDigit f i (Four a b c d)
1168 | i < sa = Four (f i a) b c d
1169 | i < sab = Four a (f (i - sa) b) c d
1170 | i < sabc = Four a b (f (i - sab) c) d
1171 | otherwise = Four a b c (f (i- sabc) d)
1172 where
1173 sa = size a
1174 sab = sa + size b
1175 sabc = sab + size c
1176
1177 -- | A generalization of 'fmap', 'mapWithIndex' takes a mapping function
1178 -- that also depends on the element's index, and applies it to every
1179 -- element in the sequence.
1180 mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
1181 mapWithIndex f xs = snd (mapAccumL' (\ i x -> (i + 1, f i x)) 0 xs)
1182
1183 -- Splitting
1184
1185 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
1186 -- If @i@ is negative, @'take' i s@ yields the empty sequence.
1187 -- If the sequence contains fewer than @i@ elements, the whole sequence
1188 -- is returned.
1189 take :: Int -> Seq a -> Seq a
1190 take i = fst . splitAt i
1191
1192 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
1193 -- If @i@ is negative, @'drop' i s@ yields the whole sequence.
1194 -- If the sequence contains fewer than @i@ elements, the empty sequence
1195 -- is returned.
1196 drop :: Int -> Seq a -> Seq a
1197 drop i = snd . splitAt i
1198
1199 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
1200 -- @'splitAt' i s = ('take' i s, 'drop' i s)@.
1201 splitAt :: Int -> Seq a -> (Seq a, Seq a)
1202 splitAt i (Seq xs) = (Seq l, Seq r)
1203 where (l, r) = split i xs
1204
1205 split :: Int -> FingerTree (Elem a) ->
1206 (FingerTree (Elem a), FingerTree (Elem a))
1207 split i Empty = i `seq` (Empty, Empty)
1208 split i xs
1209 | size xs > i = (l, consTree x r)
1210 | otherwise = (xs, Empty)
1211 where Split l x r = splitTree i xs
1212
1213 data Split t a = Split t a t
1214 #if TESTING
1215 deriving Show
1216 #endif
1217
1218 {-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
1219 {-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
1220 splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
1221 splitTree _ Empty = error "splitTree of empty tree"
1222 splitTree i (Single x) = i `seq` Split Empty x Empty
1223 splitTree i (Deep _ pr m sf)
1224 | i < spr = case splitDigit i pr of
1225 Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
1226 | i < spm = case splitTree im m of
1227 Split ml xs mr -> case splitNode (im - size ml) xs of
1228 Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
1229 | otherwise = case splitDigit (i - spm) sf of
1230 Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
1231 where
1232 spr = size pr
1233 spm = spr + size m
1234 im = i - spr
1235
1236 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1237 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1238 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
1239 splitNode i (Node2 _ a b)
1240 | i < sa = Split Nothing a (Just (One b))
1241 | otherwise = Split (Just (One a)) b Nothing
1242 where
1243 sa = size a
1244 splitNode i (Node3 _ a b c)
1245 | i < sa = Split Nothing a (Just (Two b c))
1246 | i < sab = Split (Just (One a)) b (Just (One c))
1247 | otherwise = Split (Just (Two a b)) c Nothing
1248 where
1249 sa = size a
1250 sab = sa + size b
1251
1252 {-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
1253 {-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
1254 splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
1255 splitDigit i (One a) = i `seq` Split Nothing a Nothing
1256 splitDigit i (Two a b)
1257 | i < sa = Split Nothing a (Just (One b))
1258 | otherwise = Split (Just (One a)) b Nothing
1259 where
1260 sa = size a
1261 splitDigit i (Three a b c)
1262 | i < sa = Split Nothing a (Just (Two b c))
1263 | i < sab = Split (Just (One a)) b (Just (One c))
1264 | otherwise = Split (Just (Two a b)) c Nothing
1265 where
1266 sa = size a
1267 sab = sa + size b
1268 splitDigit i (Four a b c d)
1269 | i < sa = Split Nothing a (Just (Three b c d))
1270 | i < sab = Split (Just (One a)) b (Just (Two c d))
1271 | i < sabc = Split (Just (Two a b)) c (Just (One d))
1272 | otherwise = Split (Just (Three a b c)) d Nothing
1273 where
1274 sa = size a
1275 sab = sa + size b
1276 sabc = sab + size c
1277
1278 -- | /O(n)/. Returns a sequence of all suffixes of this sequence,
1279 -- longest first. For example,
1280 --
1281 -- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]
1282 --
1283 -- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating
1284 -- every suffix in the sequence takes /O(n)/ due to sharing.
1285 tails :: Seq a -> Seq (Seq a)
1286 tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
1287
1288 -- | /O(n)/. Returns a sequence of all prefixes of this sequence,
1289 -- shortest first. For example,
1290 --
1291 -- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]
1292 --
1293 -- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating
1294 -- every prefix in the sequence takes /O(n)/ due to sharing.
1295 inits :: Seq a -> Seq (Seq a)
1296 inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
1297
1298 -- This implementation of tails (and, analogously, inits) has the
1299 -- following algorithmic advantages:
1300 -- Evaluating each tail in the sequence takes linear total time,
1301 -- which is better than we could say for
1302 -- @fromList [drop n xs | n <- [0..length xs]]@.
1303 -- Evaluating any individual tail takes logarithmic time, which is
1304 -- better than we can say for either
1305 -- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.
1306 --
1307 -- Moreover, if we actually look at every tail in the sequence, the
1308 -- following benchmarks demonstrate that this implementation is modestly
1309 -- faster than any of the above:
1310 --
1311 -- Times (ms)
1312 -- min mean +/-sd median max
1313 -- Seq.tails: 21.986 24.961 10.169 22.417 86.485
1314 -- scanr: 85.392 87.942 2.488 87.425 100.217
1315 -- iterateN: 29.952 31.245 1.574 30.412 37.268
1316 --
1317 -- The algorithm for tails (and, analogously, inits) is as follows:
1318 --
1319 -- A Node in the FingerTree of tails is constructed by evaluating the
1320 -- corresponding tail of the FingerTree of Nodes, considering the first
1321 -- Node in this tail, and constructing a Node in which each tail of this
1322 -- Node is made to be the prefix of the remaining tree. This ends up
1323 -- working quite elegantly, as the remainder of the tail of the FingerTree
1324 -- of Nodes becomes the middle of a new tail, the suffix of the Node is
1325 -- the prefix, and the suffix of the original tree is retained.
1326 --
1327 -- In particular, evaluating the /i/th tail involves making as
1328 -- many partial evaluations as the Node depth of the /i/th element.
1329 -- In addition, when we evaluate the /i/th tail, and we also evaluate
1330 -- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,
1331 -- each of those /m/ evaluations are shared between the computation of
1332 -- the /i/th and /j/th tails.
1333 --
1334 -- wasserman.louis@gmail.com, 7/16/09
1335
1336 tailsDigit :: Digit a -> Digit (Digit a)
1337 tailsDigit (One a) = One (One a)
1338 tailsDigit (Two a b) = Two (Two a b) (One b)
1339 tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
1340 tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
1341
1342 initsDigit :: Digit a -> Digit (Digit a)
1343 initsDigit (One a) = One (One a)
1344 initsDigit (Two a b) = Two (One a) (Two a b)
1345 initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
1346 initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
1347
1348 tailsNode :: Node a -> Node (Digit a)
1349 tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
1350 tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
1351
1352 initsNode :: Node a -> Node (Digit a)
1353 initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
1354 initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
1355
1356 {-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1357 {-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1358 -- | Given a function to apply to tails of a tree, applies that function
1359 -- to every tail of the specified tree.
1360 tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1361 tailsTree _ Empty = Empty
1362 tailsTree f (Single x) = Single (f (Single x))
1363 tailsTree f (Deep n pr m sf) =
1364 Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
1365 (tailsTree f' m)
1366 (fmap (f . digitToTree) (tailsDigit sf))
1367 where
1368 f' ms = let Just2 node m' = viewLTree ms in
1369 fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
1370
1371 {-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
1372 {-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
1373 -- | Given a function to apply to inits of a tree, applies that function
1374 -- to every init of the specified tree.
1375 initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b
1376 initsTree _ Empty = Empty
1377 initsTree f (Single x) = Single (f (Single x))
1378 initsTree f (Deep n pr m sf) =
1379 Deep n (fmap (f . digitToTree) (initsDigit pr))
1380 (initsTree f' m)
1381 (fmap (f . deep pr m) (initsDigit sf))
1382 where
1383 f' ms = let Just2 m' node = viewRTree ms in
1384 fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
1385
1386 {-# INLINE foldlWithIndex #-}
1387 -- | 'foldlWithIndex' is a version of 'foldl' that also provides access
1388 -- to the index of each element.
1389 foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
1390 foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)
1391
1392 {-# INLINE foldrWithIndex #-}
1393 -- | 'foldrWithIndex' is a version of 'foldr' that also provides access
1394 -- to the index of each element.
1395 foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
1396 foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0
1397
1398 {-# INLINE listToMaybe' #-}
1399 -- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.
1400 listToMaybe' :: [a] -> Maybe a
1401 listToMaybe' = foldr (\ x _ -> Just x) Nothing
1402
1403 -- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied
1404 -- to a predicate @p@ and a sequence @xs@, returns the longest prefix
1405 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1406 takeWhileL :: (a -> Bool) -> Seq a -> Seq a
1407 takeWhileL p = fst . spanl p
1408
1409 -- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied
1410 -- to a predicate @p@ and a sequence @xs@, returns the longest suffix
1411 -- (possibly empty) of @xs@ of elements that satisfy @p@.
1412 --
1413 -- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.
1414 takeWhileR :: (a -> Bool) -> Seq a -> Seq a
1415 takeWhileR p = fst . spanr p
1416
1417 -- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns
1418 -- the suffix remaining after @'takeWhileL' p xs@.
1419 dropWhileL :: (a -> Bool) -> Seq a -> Seq a
1420 dropWhileL p = snd . spanl p
1421
1422 -- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns
1423 -- the prefix remaining after @'takeWhileR' p xs@.
1424 --
1425 -- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.
1426 dropWhileR :: (a -> Bool) -> Seq a -> Seq a
1427 dropWhileR p = snd . spanr p
1428
1429 -- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to
1430 -- a predicate @p@ and a sequence @xs@, returns a pair whose first
1431 -- element is the longest prefix (possibly empty) of @xs@ of elements that
1432 -- satisfy @p@ and the second element is the remainder of the sequence.
1433 spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1434 spanl p = breakl (not . p)
1435
1436 -- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a
1437 -- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element
1438 -- is the longest /suffix/ (possibly empty) of @xs@ of elements that
1439 -- satisfy @p@ and the second element is the remainder of the sequence.
1440 spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1441 spanr p = breakr (not . p)
1442
1443 {-# INLINE breakl #-}
1444 -- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a
1445 -- predicate @p@ and a sequence @xs@, returns a pair whose first element
1446 -- is the longest prefix (possibly empty) of @xs@ of elements that
1447 -- /do not satisfy/ @p@ and the second element is the remainder of
1448 -- the sequence.
1449 --
1450 -- @'breakl' p@ is equivalent to @'spanl' (not . p)@.
1451 breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1452 breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
1453
1454 {-# INLINE breakr #-}
1455 -- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.
1456 breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1457 breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
1458 where flipPair (x, y) = (y, x)
1459
1460 -- | /O(n)/. The 'partition' function takes a predicate @p@ and a
1461 -- sequence @xs@ and returns sequences of those elements which do and
1462 -- do not satisfy the predicate.
1463 partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
1464 partition p = foldl part (empty, empty)
1465 where
1466 part (xs, ys) x
1467 | p x = (xs |> x, ys)
1468 | otherwise = (xs, ys |> x)
1469
1470 -- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence
1471 -- @xs@ and returns a sequence of those elements which satisfy the
1472 -- predicate.
1473 filter :: (a -> Bool) -> Seq a -> Seq a
1474 filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty
1475
1476 -- Indexing sequences
1477
1478 -- | 'elemIndexL' finds the leftmost index of the specified element,
1479 -- if it is present, and otherwise 'Nothing'.
1480 elemIndexL :: Eq a => a -> Seq a -> Maybe Int
1481 elemIndexL x = findIndexL (x ==)
1482
1483 -- | 'elemIndexR' finds the rightmost index of the specified element,
1484 -- if it is present, and otherwise 'Nothing'.
1485 elemIndexR :: Eq a => a -> Seq a -> Maybe Int
1486 elemIndexR x = findIndexR (x ==)
1487
1488 -- | 'elemIndicesL' finds the indices of the specified element, from
1489 -- left to right (i.e. in ascending order).
1490 elemIndicesL :: Eq a => a -> Seq a -> [Int]
1491 elemIndicesL x = findIndicesL (x ==)
1492
1493 -- | 'elemIndicesR' finds the indices of the specified element, from
1494 -- right to left (i.e. in descending order).
1495 elemIndicesR :: Eq a => a -> Seq a -> [Int]
1496 elemIndicesR x = findIndicesR (x ==)
1497
1498 -- | @'findIndexL' p xs@ finds the index of the leftmost element that
1499 -- satisfies @p@, if any exist.
1500 findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
1501 findIndexL p = listToMaybe' . findIndicesL p
1502
1503 -- | @'findIndexR' p xs@ finds the index of the rightmost element that
1504 -- satisfies @p@, if any exist.
1505 findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
1506 findIndexR p = listToMaybe' . findIndicesR p
1507
1508 {-# INLINE findIndicesL #-}
1509 -- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,
1510 -- in ascending order.
1511 findIndicesL :: (a -> Bool) -> Seq a -> [Int]
1512 #if __GLASGOW_HASKELL__
1513 findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
1514 foldrWithIndex g n xs)
1515 #else
1516 findIndicesL p xs = foldrWithIndex g [] xs
1517 where g i x is = if p x then i:is else is
1518 #endif
1519
1520 {-# INLINE findIndicesR #-}
1521 -- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,
1522 -- in descending order.
1523 findIndicesR :: (a -> Bool) -> Seq a -> [Int]
1524 #if __GLASGOW_HASKELL__
1525 findIndicesR p xs = build (\ c n ->
1526 let g z i x = if p x then c i z else z in foldlWithIndex g n xs)
1527 #else
1528 findIndicesR p xs = foldlWithIndex g [] xs
1529 where g is i x = if p x then i:is else is
1530 #endif
1531
1532 ------------------------------------------------------------------------
1533 -- Lists
1534 ------------------------------------------------------------------------
1535
1536 -- | /O(n)/. Create a sequence from a finite list of elements.
1537 -- There is a function 'toList' in the opposite direction for all
1538 -- instances of the 'Foldable' class, including 'Seq'.
1539 fromList :: [a] -> Seq a
1540 fromList = Data.List.foldl' (|>) empty
1541
1542 ------------------------------------------------------------------------
1543 -- Reverse
1544 ------------------------------------------------------------------------
1545
1546 -- | /O(n)/. The reverse of a sequence.
1547 reverse :: Seq a -> Seq a
1548 reverse (Seq xs) = Seq (reverseTree id xs)
1549
1550 reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
1551 reverseTree _ Empty = Empty
1552 reverseTree f (Single x) = Single (f x)
1553 reverseTree f (Deep s pr m sf) =
1554 Deep s (reverseDigit f sf)
1555 (reverseTree (reverseNode f) m)
1556 (reverseDigit f pr)
1557
1558 {-# INLINE reverseDigit #-}
1559 reverseDigit :: (a -> a) -> Digit a -> Digit a
1560 reverseDigit f (One a) = One (f a)
1561 reverseDigit f (Two a b) = Two (f b) (f a)
1562 reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
1563 reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
1564
1565 reverseNode :: (a -> a) -> Node a -> Node a
1566 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
1567 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
1568
1569 ------------------------------------------------------------------------
1570 -- Zipping
1571 ------------------------------------------------------------------------
1572
1573 -- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence
1574 -- of corresponding pairs. If one input is short, excess elements are
1575 -- discarded from the right end of the longer sequence.
1576 zip :: Seq a -> Seq b -> Seq (a, b)
1577 zip = zipWith (,)
1578
1579 -- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the
1580 -- function given as the first argument, instead of a tupling function.
1581 -- For example, @zipWith (+)@ is applied to two sequences to take the
1582 -- sequence of corresponding sums.
1583 zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
1584 zipWith f xs ys
1585 | length xs <= length ys = zipWith' f xs ys
1586 | otherwise = zipWith' (flip f) ys xs
1587
1588 -- like 'zipWith', but assumes length xs <= length ys
1589 zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
1590 zipWith' f xs ys = snd (mapAccumL k ys xs)
1591 where
1592 k kys x = case viewl kys of
1593 (z :< zs) -> (zs, f x z)
1594 EmptyL -> error "zipWith': unexpected EmptyL"
1595
1596 -- | /O(min(n1,n2,n3))/. 'zip3' takes three sequences and returns a
1597 -- sequence of triples, analogous to 'zip'.
1598 zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
1599 zip3 = zipWith3 (,,)
1600
1601 -- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines
1602 -- three elements, as well as three sequences and returns a sequence of
1603 -- their point-wise combinations, analogous to 'zipWith'.
1604 zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
1605 zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3
1606
1607 -- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a
1608 -- sequence of quadruples, analogous to 'zip'.
1609 zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
1610 zip4 = zipWith4 (,,,)
1611
1612 -- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines
1613 -- four elements, as well as four sequences and returns a sequence of
1614 -- their point-wise combinations, analogous to 'zipWith'.
1615 zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
1616 zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4
1617
1618 ------------------------------------------------------------------------
1619 -- Sorting
1620 --
1621 -- sort and sortBy are implemented by simple deforestations of
1622 -- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList
1623 -- which does not get deforested automatically, it would appear.
1624 --
1625 -- Unstable sorting is performed by a heap sort implementation based on
1626 -- pairing heaps. Because the internal structure of sequences is quite
1627 -- varied, it is difficult to get blocks of elements of roughly the same
1628 -- length, which would improve merge sort performance. Pairing heaps,
1629 -- on the other hand, are relatively resistant to the effects of merging
1630 -- heaps of wildly different sizes, as guaranteed by its amortized
1631 -- constant-time merge operation. Moreover, extensive use of SpecConstr
1632 -- transformations can be done on pairing heaps, especially when we're
1633 -- only constructing them to immediately be unrolled.
1634 --
1635 -- On purely random sequences of length 50000, with no RTS options,
1636 -- I get the following statistics, in which heapsort is about 42.5%
1637 -- faster: (all comparisons done with -O2)
1638 --
1639 -- Times (ms) min mean +/-sd median max
1640 -- to/from list: 103.802 108.572 7.487 106.436 143.339
1641 -- unstable heapsort: 60.686 62.968 4.275 61.187 79.151
1642 --
1643 -- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.
1644 -- The gap is narrowed when more memory is available, but heapsort still
1645 -- wins, 15% faster, with +RTS -H128m:
1646 --
1647 -- Times (ms) min mean +/-sd median max
1648 -- to/from list: 42.692 45.074 2.596 44.600 56.601
1649 -- unstable heapsort: 37.100 38.344 3.043 37.715 55.526
1650 --
1651 -- In addition, on strictly increasing sequences the gap is even wider
1652 -- than normal; heapsort is 68.5% faster with no RTS options:
1653 -- Times (ms) min mean +/-sd median max
1654 -- to/from list: 52.236 53.574 1.987 53.034 62.098
1655 -- unstable heapsort: 16.433 16.919 0.931 16.681 21.622
1656 --
1657 -- This may be attributed to the elegant nature of the pairing heap.
1658 --
1659 -- wasserman.louis@gmail.com, 7/20/09
1660 ------------------------------------------------------------------------
1661
1662 -- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural
1663 -- ordering of its elements. The sort is stable.
1664 -- If stability is not required, 'unstableSort' can be considerably
1665 -- faster, and in particular uses less memory.
1666 sort :: Ord a => Seq a -> Seq a
1667 sort = sortBy compare
1668
1669 -- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the
1670 -- specified comparator. The sort is stable.
1671 -- If stability is not required, 'unstableSortBy' can be considerably
1672 -- faster, and in particular uses less memory.
1673 sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
1674 sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
1675
1676 -- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by
1677 -- the natural ordering of its elements, but the sort is not stable.
1678 -- This algorithm is frequently faster and uses less memory than 'sort',
1679 -- and performs extremely well -- frequently twice as fast as 'sort' --
1680 -- when the sequence is already nearly sorted.
1681 unstableSort :: Ord a => Seq a -> Seq a
1682 unstableSort = unstableSortBy compare
1683
1684 -- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'
1685 -- takes an arbitrary comparator and sorts the specified sequence.
1686 -- The sort is not stable. This algorithm is frequently faster and
1687 -- uses less memory than 'sortBy', and performs extremely well --
1688 -- frequently twice as fast as 'sortBy' -- when the sequence is already
1689 -- nearly sorted.
1690 unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
1691 unstableSortBy cmp (Seq xs) =
1692 fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
1693 toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
1694
1695 -- | fromList2, given a list and its length, constructs a completely
1696 -- balanced Seq whose elements are that list using the applicativeTree
1697 -- generalization.
1698 fromList2 :: Int -> [a] -> Seq a
1699 fromList2 n = execState (replicateA n (State ht))
1700 where
1701 ht (x:xs) = (xs, x)
1702 ht [] = error "fromList2: short list"
1703
1704 -- | A 'PQueue' is a simple pairing heap.
1705 data PQueue e = PQueue e (PQL e)
1706 data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e
1707
1708 infixr 8 :&
1709
1710 #if TESTING
1711
1712 instance Functor PQueue where
1713 fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)
1714
1715 instance Functor PQL where
1716 fmap f (q :& qs) = fmap f q :& fmap f qs
1717 fmap _ Nil = Nil
1718
1719 instance Show e => Show (PQueue e) where
1720 show = unlines . draw . fmap show
1721
1722 -- borrowed wholesale from Data.Tree, as Data.Tree actually depends
1723 -- on Data.Sequence
1724 draw :: PQueue String -> [String]
1725 draw (PQueue x ts0) = x : drawSubTrees ts0
1726 where
1727 drawSubTrees Nil = []
1728 drawSubTrees (t :& Nil) =
1729 "|" : shift "`- " " " (draw t)
1730 drawSubTrees (t :& ts) =
1731 "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
1732
1733 shift first other = Data.List.zipWith (++) (first : repeat other)
1734 #endif
1735
1736 -- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into
1737 -- a sorted list.
1738 unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
1739 unrollPQ cmp = unrollPQ'
1740 where
1741 {-# INLINE unrollPQ' #-}
1742 unrollPQ' (PQueue x ts) = x:mergePQs0 ts
1743 (<>) = mergePQ cmp
1744 mergePQs0 Nil = []
1745 mergePQs0 (t :& Nil) = unrollPQ' t
1746 mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts
1747 mergePQs t ts = t `seq` case ts of
1748 Nil -> unrollPQ' t
1749 t1 :& Nil -> unrollPQ' (t <> t1)
1750 t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'
1751
1752 -- | 'toPQ', given an ordering function and a mechanism for queueifying
1753 -- elements, converts a 'FingerTree' to a 'PQueue'.
1754 toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)
1755 toPQ _ _ Empty = Nothing
1756 toPQ _ f (Single x) = Just (f x)
1757 toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))
1758 where
1759 fDigit digit = case fmap f digit of
1760 One a -> a
1761 Two a b -> a <> b
1762 Three a b c -> a <> b <> c
1763 Four a b c d -> (a <> b) <> (c <> d)
1764 (<>) = mergePQ cmp
1765 fNode = fDigit . nodeToDigit
1766 pr' = fDigit pr
1767 sf' = fDigit sf
1768
1769 -- | 'mergePQ' merges two 'PQueue's.
1770 mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a
1771 mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)
1772 | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)
1773 | otherwise = PQueue x1 (q2 :& ts1)
1774
1775 #if TESTING
1776
1777 ------------------------------------------------------------------------
1778 -- QuickCheck
1779 ------------------------------------------------------------------------
1780
1781 instance Arbitrary a => Arbitrary (Seq a) where
1782 arbitrary = Seq <$> arbitrary
1783 shrink (Seq x) = map Seq (shrink x)
1784
1785 instance Arbitrary a => Arbitrary (Elem a) where
1786 arbitrary = Elem <$> arbitrary
1787
1788 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
1789 arbitrary = sized arb
1790 where
1791 arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
1792 arb 0 = return Empty
1793 arb 1 = Single <$> arbitrary
1794 arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary
1795
1796 shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]
1797 shrink (Deep _ pr m sf) =
1798 [deep pr' m sf | pr' <- shrink pr] ++
1799 [deep pr m' sf | m' <- shrink m] ++
1800 [deep pr m sf' | sf' <- shrink sf]
1801 shrink (Single x) = map Single (shrink x)
1802 shrink Empty = []
1803
1804 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
1805 arbitrary = oneof [
1806 node2 <$> arbitrary <*> arbitrary,
1807 node3 <$> arbitrary <*> arbitrary <*> arbitrary]
1808
1809 shrink (Node2 _ a b) =
1810 [node2 a' b | a' <- shrink a] ++
1811 [node2 a b' | b' <- shrink b]
1812 shrink (Node3 _ a b c) =
1813 [node2 a b, node2 a c, node2 b c] ++
1814 [node3 a' b c | a' <- shrink a] ++
1815 [node3 a b' c | b' <- shrink b] ++
1816 [node3 a b c' | c' <- shrink c]
1817
1818 instance Arbitrary a => Arbitrary (Digit a) where
1819 arbitrary = oneof [
1820 One <$> arbitrary,
1821 Two <$> arbitrary <*> arbitrary,
1822 Three <$> arbitrary <*> arbitrary <*> arbitrary,
1823 Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]
1824
1825 shrink (One a) = map One (shrink a)
1826 shrink (Two a b) = [One a, One b]
1827 shrink (Three a b c) = [Two a b, Two a c, Two b c]
1828 shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]
1829
1830 ------------------------------------------------------------------------
1831 -- Valid trees
1832 ------------------------------------------------------------------------
1833
1834 class Valid a where
1835 valid :: a -> Bool
1836
1837 instance Valid (Elem a) where
1838 valid _ = True
1839
1840 instance Valid (Seq a) where
1841 valid (Seq xs) = valid xs
1842
1843 instance (Sized a, Valid a) => Valid (FingerTree a) where
1844 valid Empty = True
1845 valid (Single x) = valid x
1846 valid (Deep s pr m sf) =
1847 s == size pr + size m + size sf && valid pr && valid m && valid sf
1848
1849 instance (Sized a, Valid a) => Valid (Node a) where
1850 valid node = size node == sum (fmap size node) && all valid node
1851
1852 instance Valid a => Valid (Digit a) where
1853 valid = all valid
1854
1855 #endif