Remove Control.Parallel*, now in package parallel
[packages/random.git] / Data / Sequence.hs
1 {-# OPTIONS -cpp -fglasgow-exts #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Data.Sequence
5 -- Copyright : (c) Ross Paterson 2005
6 -- License : BSD-style
7 -- Maintainer : ross@soi.city.ac.uk
8 -- Stability : experimental
9 -- Portability : portable
10 --
11 -- General purpose finite sequences.
12 -- Apart from being finite and having strict operations, sequences
13 -- also differ from lists in supporting a wider variety of operations
14 -- efficiently.
15 --
16 -- An amortized running time is given for each operation, with /n/ referring
17 -- to the length of the sequence and /i/ being the integral index used by
18 -- some operations. These bounds hold even in a persistent (shared) setting.
19 --
20 -- The implementation uses 2-3 finger trees annotated with sizes,
21 -- as described in section 4.2 of
22 --
23 -- * Ralf Hinze and Ross Paterson,
24 -- \"Finger trees: a simple general-purpose data structure\",
25 -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
26 -- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
27 --
28 -- /Note/: Many of these operations have the same names as similar
29 -- operations on lists in the "Prelude". The ambiguity may be resolved
30 -- using either qualification or the @hiding@ clause.
31 --
32 -----------------------------------------------------------------------------
33
34 module Data.Sequence (
35 Seq,
36 -- * Construction
37 empty, -- :: Seq a
38 singleton, -- :: a -> Seq a
39 (<|), -- :: a -> Seq a -> Seq a
40 (|>), -- :: Seq a -> a -> Seq a
41 (><), -- :: Seq a -> Seq a -> Seq a
42 fromList, -- :: [a] -> Seq a
43 -- * Deconstruction
44 -- | Additional functions for deconstructing sequences are available
45 -- via the 'Foldable' instance of 'Seq'.
46
47 -- ** Queries
48 null, -- :: Seq a -> Bool
49 length, -- :: Seq a -> Int
50 -- ** Views
51 ViewL(..),
52 viewl, -- :: Seq a -> ViewL a
53 ViewR(..),
54 viewr, -- :: Seq a -> ViewR a
55 -- ** Indexing
56 index, -- :: Seq a -> Int -> a
57 adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a
58 update, -- :: Int -> a -> Seq a -> Seq a
59 take, -- :: Int -> Seq a -> Seq a
60 drop, -- :: Int -> Seq a -> Seq a
61 splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)
62 -- * Transformations
63 reverse, -- :: Seq a -> Seq a
64 #if TESTING
65 valid,
66 #endif
67 ) where
68
69 import Prelude hiding (
70 null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
71 reverse)
72 import qualified Data.List (foldl')
73 import Control.Applicative (Applicative(..), (<$>))
74 import Control.Monad (MonadPlus(..))
75 import Data.Monoid (Monoid(..))
76 import Data.Foldable
77 import Data.Traversable
78 import Data.Typeable
79
80 #ifdef __GLASGOW_HASKELL__
81 import Text.Read (Lexeme(Ident), lexP, parens, prec,
82 readPrec, readListPrec, readListPrecDefault)
83 import Data.Generics.Basics (Data(..), Fixity(..),
84 constrIndex, mkConstr, mkDataType)
85 #endif
86
87 #if TESTING
88 import Control.Monad (liftM, liftM3, liftM4)
89 import Test.QuickCheck
90 #endif
91
92 infixr 5 `consTree`
93 infixl 5 `snocTree`
94
95 infixr 5 ><
96 infixr 5 <|, :<
97 infixl 5 |>, :>
98
99 class Sized a where
100 size :: a -> Int
101
102 -- | General-purpose finite sequences.
103 newtype Seq a = Seq (FingerTree (Elem a))
104
105 instance Functor Seq where
106 fmap f (Seq xs) = Seq (fmap (fmap f) xs)
107
108 instance Foldable Seq where
109 foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
110 foldl f z (Seq xs) = foldl (foldl f) z xs
111
112 foldr1 f (Seq xs) = getElem (foldr1 f' xs)
113 where f' (Elem x) (Elem y) = Elem (f x y)
114
115 foldl1 f (Seq xs) = getElem (foldl1 f' xs)
116 where f' (Elem x) (Elem y) = Elem (f x y)
117
118 instance Traversable Seq where
119 traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
120
121 instance Monad Seq where
122 return = singleton
123 xs >>= f = foldl' add empty xs
124 where add ys x = ys >< f x
125
126 instance MonadPlus Seq where
127 mzero = empty
128 mplus = (><)
129
130 instance Eq a => Eq (Seq a) where
131 xs == ys = length xs == length ys && toList xs == toList ys
132
133 instance Ord a => Ord (Seq a) where
134 compare xs ys = compare (toList xs) (toList ys)
135
136 #if TESTING
137 instance Show a => Show (Seq a) where
138 showsPrec p (Seq x) = showsPrec p x
139 #else
140 instance Show a => Show (Seq a) where
141 showsPrec p xs = showParen (p > 10) $
142 showString "fromList " . shows (toList xs)
143 #endif
144
145 instance Read a => Read (Seq a) where
146 #ifdef __GLASGOW_HASKELL__
147 readPrec = parens $ prec 10 $ do
148 Ident "fromList" <- lexP
149 xs <- readPrec
150 return (fromList xs)
151
152 readListPrec = readListPrecDefault
153 #else
154 readsPrec p = readParen (p > 10) $ \ r -> do
155 ("fromList",s) <- lex r
156 (xs,t) <- reads s
157 return (fromList xs,t)
158 #endif
159
160 instance Monoid (Seq a) where
161 mempty = empty
162 mappend = (><)
163
164 #include "Typeable.h"
165 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
166
167 #if __GLASGOW_HASKELL__
168 instance Data a => Data (Seq a) where
169 gfoldl f z s = case viewl s of
170 EmptyL -> z empty
171 x :< xs -> z (<|) `f` x `f` xs
172
173 gunfold k z c = case constrIndex c of
174 1 -> z empty
175 2 -> k (k (z (<|)))
176 _ -> error "gunfold"
177
178 toConstr xs
179 | null xs = emptyConstr
180 | otherwise = consConstr
181
182 dataTypeOf _ = seqDataType
183
184 dataCast1 f = gcast1 f
185
186 emptyConstr = mkConstr seqDataType "empty" [] Prefix
187 consConstr = mkConstr seqDataType "<|" [] Infix
188 seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
189 #endif
190
191 -- Finger trees
192
193 data FingerTree a
194 = Empty
195 | Single a
196 | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
197 #if TESTING
198 deriving Show
199 #endif
200
201 instance Sized a => Sized (FingerTree a) where
202 {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
203 {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
204 size Empty = 0
205 size (Single x) = size x
206 size (Deep v _ _ _) = v
207
208 instance Foldable FingerTree where
209 foldr _ z Empty = z
210 foldr f z (Single x) = x `f` z
211 foldr f z (Deep _ pr m sf) =
212 foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
213
214 foldl _ z Empty = z
215 foldl f z (Single x) = z `f` x
216 foldl f z (Deep _ pr m sf) =
217 foldl f (foldl (foldl f) (foldl f z pr) m) sf
218
219 foldr1 _ Empty = error "foldr1: empty sequence"
220 foldr1 _ (Single x) = x
221 foldr1 f (Deep _ pr m sf) =
222 foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
223
224 foldl1 _ Empty = error "foldl1: empty sequence"
225 foldl1 _ (Single x) = x
226 foldl1 f (Deep _ pr m sf) =
227 foldl f (foldl (foldl f) (foldl1 f pr) m) sf
228
229 instance Functor FingerTree where
230 fmap _ Empty = Empty
231 fmap f (Single x) = Single (f x)
232 fmap f (Deep v pr m sf) =
233 Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
234
235 instance Traversable FingerTree where
236 traverse _ Empty = pure Empty
237 traverse f (Single x) = Single <$> f x
238 traverse f (Deep v pr m sf) =
239 Deep v <$> traverse f pr <*> traverse (traverse f) m <*>
240 traverse f sf
241
242 {-# INLINE deep #-}
243 {-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
244 {-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
245 deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
246 deep pr m sf = Deep (size pr + size m + size sf) pr m sf
247
248 -- Digits
249
250 data Digit a
251 = One a
252 | Two a a
253 | Three a a a
254 | Four a a a a
255 #if TESTING
256 deriving Show
257 #endif
258
259 instance Foldable Digit where
260 foldr f z (One a) = a `f` z
261 foldr f z (Two a b) = a `f` (b `f` z)
262 foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
263 foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
264
265 foldl f z (One a) = z `f` a
266 foldl f z (Two a b) = (z `f` a) `f` b
267 foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
268 foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
269
270 foldr1 f (One a) = a
271 foldr1 f (Two a b) = a `f` b
272 foldr1 f (Three a b c) = a `f` (b `f` c)
273 foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
274
275 foldl1 f (One a) = a
276 foldl1 f (Two a b) = a `f` b
277 foldl1 f (Three a b c) = (a `f` b) `f` c
278 foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
279
280 instance Functor Digit where
281 fmap = fmapDefault
282
283 instance Traversable Digit where
284 traverse f (One a) = One <$> f a
285 traverse f (Two a b) = Two <$> f a <*> f b
286 traverse f (Three a b c) = Three <$> f a <*> f b <*> f c
287 traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
288
289 instance Sized a => Sized (Digit a) where
290 {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
291 {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
292 size xs = foldl (\ i x -> i + size x) 0 xs
293
294 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
295 {-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
296 digitToTree :: Sized a => Digit a -> FingerTree a
297 digitToTree (One a) = Single a
298 digitToTree (Two a b) = deep (One a) Empty (One b)
299 digitToTree (Three a b c) = deep (Two a b) Empty (One c)
300 digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
301
302 -- Nodes
303
304 data Node a
305 = Node2 {-# UNPACK #-} !Int a a
306 | Node3 {-# UNPACK #-} !Int a a a
307 #if TESTING
308 deriving Show
309 #endif
310
311 instance Foldable Node where
312 foldr f z (Node2 _ a b) = a `f` (b `f` z)
313 foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
314
315 foldl f z (Node2 _ a b) = (z `f` a) `f` b
316 foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
317
318 instance Functor Node where
319 fmap = fmapDefault
320
321 instance Traversable Node where
322 traverse f (Node2 v a b) = Node2 v <$> f a <*> f b
323 traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
324
325 instance Sized (Node a) where
326 size (Node2 v _ _) = v
327 size (Node3 v _ _ _) = v
328
329 {-# INLINE node2 #-}
330 {-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
331 {-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
332 node2 :: Sized a => a -> a -> Node a
333 node2 a b = Node2 (size a + size b) a b
334
335 {-# INLINE node3 #-}
336 {-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
337 {-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
338 node3 :: Sized a => a -> a -> a -> Node a
339 node3 a b c = Node3 (size a + size b + size c) a b c
340
341 nodeToDigit :: Node a -> Digit a
342 nodeToDigit (Node2 _ a b) = Two a b
343 nodeToDigit (Node3 _ a b c) = Three a b c
344
345 -- Elements
346
347 newtype Elem a = Elem { getElem :: a }
348
349 instance Sized (Elem a) where
350 size _ = 1
351
352 instance Functor Elem where
353 fmap f (Elem x) = Elem (f x)
354
355 instance Foldable Elem where
356 foldr f z (Elem x) = f x z
357 foldl f z (Elem x) = f z x
358
359 instance Traversable Elem where
360 traverse f (Elem x) = Elem <$> f x
361
362 #ifdef TESTING
363 instance (Show a) => Show (Elem a) where
364 showsPrec p (Elem x) = showsPrec p x
365 #endif
366
367 ------------------------------------------------------------------------
368 -- Construction
369 ------------------------------------------------------------------------
370
371 -- | /O(1)/. The empty sequence.
372 empty :: Seq a
373 empty = Seq Empty
374
375 -- | /O(1)/. A singleton sequence.
376 singleton :: a -> Seq a
377 singleton x = Seq (Single (Elem x))
378
379 -- | /O(1)/. Add an element to the left end of a sequence.
380 -- Mnemonic: a triangle with the single element at the pointy end.
381 (<|) :: a -> Seq a -> Seq a
382 x <| Seq xs = Seq (Elem x `consTree` xs)
383
384 {-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
385 {-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
386 consTree :: Sized a => a -> FingerTree a -> FingerTree a
387 consTree a Empty = Single a
388 consTree a (Single b) = deep (One a) Empty (One b)
389 consTree a (Deep s (Four b c d e) m sf) = m `seq`
390 Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
391 consTree a (Deep s (Three b c d) m sf) =
392 Deep (size a + s) (Four a b c d) m sf
393 consTree a (Deep s (Two b c) m sf) =
394 Deep (size a + s) (Three a b c) m sf
395 consTree a (Deep s (One b) m sf) =
396 Deep (size a + s) (Two a b) m sf
397
398 -- | /O(1)/. Add an element to the right end of a sequence.
399 -- Mnemonic: a triangle with the single element at the pointy end.
400 (|>) :: Seq a -> a -> Seq a
401 Seq xs |> x = Seq (xs `snocTree` Elem x)
402
403 {-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
404 {-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
405 snocTree :: Sized a => FingerTree a -> a -> FingerTree a
406 snocTree Empty a = Single a
407 snocTree (Single a) b = deep (One a) Empty (One b)
408 snocTree (Deep s pr m (Four a b c d)) e = m `seq`
409 Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
410 snocTree (Deep s pr m (Three a b c)) d =
411 Deep (s + size d) pr m (Four a b c d)
412 snocTree (Deep s pr m (Two a b)) c =
413 Deep (s + size c) pr m (Three a b c)
414 snocTree (Deep s pr m (One a)) b =
415 Deep (s + size b) pr m (Two a b)
416
417 -- | /O(log(min(n1,n2)))/. Concatenate two sequences.
418 (><) :: Seq a -> Seq a -> Seq a
419 Seq xs >< Seq ys = Seq (appendTree0 xs ys)
420
421 -- The appendTree/addDigits gunk below is machine generated
422
423 appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
424 appendTree0 Empty xs =
425 xs
426 appendTree0 xs Empty =
427 xs
428 appendTree0 (Single x) xs =
429 x `consTree` xs
430 appendTree0 xs (Single x) =
431 xs `snocTree` x
432 appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
433 Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2
434
435 addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
436 addDigits0 m1 (One a) (One b) m2 =
437 appendTree1 m1 (node2 a b) m2
438 addDigits0 m1 (One a) (Two b c) m2 =
439 appendTree1 m1 (node3 a b c) m2
440 addDigits0 m1 (One a) (Three b c d) m2 =
441 appendTree2 m1 (node2 a b) (node2 c d) m2
442 addDigits0 m1 (One a) (Four b c d e) m2 =
443 appendTree2 m1 (node3 a b c) (node2 d e) m2
444 addDigits0 m1 (Two a b) (One c) m2 =
445 appendTree1 m1 (node3 a b c) m2
446 addDigits0 m1 (Two a b) (Two c d) m2 =
447 appendTree2 m1 (node2 a b) (node2 c d) m2
448 addDigits0 m1 (Two a b) (Three c d e) m2 =
449 appendTree2 m1 (node3 a b c) (node2 d e) m2
450 addDigits0 m1 (Two a b) (Four c d e f) m2 =
451 appendTree2 m1 (node3 a b c) (node3 d e f) m2
452 addDigits0 m1 (Three a b c) (One d) m2 =
453 appendTree2 m1 (node2 a b) (node2 c d) m2
454 addDigits0 m1 (Three a b c) (Two d e) m2 =
455 appendTree2 m1 (node3 a b c) (node2 d e) m2
456 addDigits0 m1 (Three a b c) (Three d e f) m2 =
457 appendTree2 m1 (node3 a b c) (node3 d e f) m2
458 addDigits0 m1 (Three a b c) (Four d e f g) m2 =
459 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
460 addDigits0 m1 (Four a b c d) (One e) m2 =
461 appendTree2 m1 (node3 a b c) (node2 d e) m2
462 addDigits0 m1 (Four a b c d) (Two e f) m2 =
463 appendTree2 m1 (node3 a b c) (node3 d e f) m2
464 addDigits0 m1 (Four a b c d) (Three e f g) m2 =
465 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
466 addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
467 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
468
469 appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
470 appendTree1 Empty a xs =
471 a `consTree` xs
472 appendTree1 xs a Empty =
473 xs `snocTree` a
474 appendTree1 (Single x) a xs =
475 x `consTree` a `consTree` xs
476 appendTree1 xs a (Single x) =
477 xs `snocTree` a `snocTree` x
478 appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
479 Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
480
481 addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
482 addDigits1 m1 (One a) b (One c) m2 =
483 appendTree1 m1 (node3 a b c) m2
484 addDigits1 m1 (One a) b (Two c d) m2 =
485 appendTree2 m1 (node2 a b) (node2 c d) m2
486 addDigits1 m1 (One a) b (Three c d e) m2 =
487 appendTree2 m1 (node3 a b c) (node2 d e) m2
488 addDigits1 m1 (One a) b (Four c d e f) m2 =
489 appendTree2 m1 (node3 a b c) (node3 d e f) m2
490 addDigits1 m1 (Two a b) c (One d) m2 =
491 appendTree2 m1 (node2 a b) (node2 c d) m2
492 addDigits1 m1 (Two a b) c (Two d e) m2 =
493 appendTree2 m1 (node3 a b c) (node2 d e) m2
494 addDigits1 m1 (Two a b) c (Three d e f) m2 =
495 appendTree2 m1 (node3 a b c) (node3 d e f) m2
496 addDigits1 m1 (Two a b) c (Four d e f g) m2 =
497 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
498 addDigits1 m1 (Three a b c) d (One e) m2 =
499 appendTree2 m1 (node3 a b c) (node2 d e) m2
500 addDigits1 m1 (Three a b c) d (Two e f) m2 =
501 appendTree2 m1 (node3 a b c) (node3 d e f) m2
502 addDigits1 m1 (Three a b c) d (Three e f g) m2 =
503 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
504 addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
505 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
506 addDigits1 m1 (Four a b c d) e (One f) m2 =
507 appendTree2 m1 (node3 a b c) (node3 d e f) m2
508 addDigits1 m1 (Four a b c d) e (Two f g) m2 =
509 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
510 addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
511 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
512 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
513 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
514
515 appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
516 appendTree2 Empty a b xs =
517 a `consTree` b `consTree` xs
518 appendTree2 xs a b Empty =
519 xs `snocTree` a `snocTree` b
520 appendTree2 (Single x) a b xs =
521 x `consTree` a `consTree` b `consTree` xs
522 appendTree2 xs a b (Single x) =
523 xs `snocTree` a `snocTree` b `snocTree` x
524 appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
525 Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
526
527 addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
528 addDigits2 m1 (One a) b c (One d) m2 =
529 appendTree2 m1 (node2 a b) (node2 c d) m2
530 addDigits2 m1 (One a) b c (Two d e) m2 =
531 appendTree2 m1 (node3 a b c) (node2 d e) m2
532 addDigits2 m1 (One a) b c (Three d e f) m2 =
533 appendTree2 m1 (node3 a b c) (node3 d e f) m2
534 addDigits2 m1 (One a) b c (Four d e f g) m2 =
535 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
536 addDigits2 m1 (Two a b) c d (One e) m2 =
537 appendTree2 m1 (node3 a b c) (node2 d e) m2
538 addDigits2 m1 (Two a b) c d (Two e f) m2 =
539 appendTree2 m1 (node3 a b c) (node3 d e f) m2
540 addDigits2 m1 (Two a b) c d (Three e f g) m2 =
541 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
542 addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
543 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
544 addDigits2 m1 (Three a b c) d e (One f) m2 =
545 appendTree2 m1 (node3 a b c) (node3 d e f) m2
546 addDigits2 m1 (Three a b c) d e (Two f g) m2 =
547 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
548 addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
549 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
550 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
551 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
552 addDigits2 m1 (Four a b c d) e f (One g) m2 =
553 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
554 addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
555 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
556 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
557 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
558 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
559 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
560
561 appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
562 appendTree3 Empty a b c xs =
563 a `consTree` b `consTree` c `consTree` xs
564 appendTree3 xs a b c Empty =
565 xs `snocTree` a `snocTree` b `snocTree` c
566 appendTree3 (Single x) a b c xs =
567 x `consTree` a `consTree` b `consTree` c `consTree` xs
568 appendTree3 xs a b c (Single x) =
569 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
570 appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
571 Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
572
573 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))
574 addDigits3 m1 (One a) b c d (One e) m2 =
575 appendTree2 m1 (node3 a b c) (node2 d e) m2
576 addDigits3 m1 (One a) b c d (Two e f) m2 =
577 appendTree2 m1 (node3 a b c) (node3 d e f) m2
578 addDigits3 m1 (One a) b c d (Three e f g) m2 =
579 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
580 addDigits3 m1 (One a) b c d (Four e f g h) m2 =
581 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
582 addDigits3 m1 (Two a b) c d e (One f) m2 =
583 appendTree2 m1 (node3 a b c) (node3 d e f) m2
584 addDigits3 m1 (Two a b) c d e (Two f g) m2 =
585 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
586 addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
587 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
588 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
589 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
590 addDigits3 m1 (Three a b c) d e f (One g) m2 =
591 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
592 addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
593 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
594 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
595 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
596 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
597 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
598 addDigits3 m1 (Four a b c d) e f g (One h) m2 =
599 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
600 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
601 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
602 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
603 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
604 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
605 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
606
607 appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
608 appendTree4 Empty a b c d xs =
609 a `consTree` b `consTree` c `consTree` d `consTree` xs
610 appendTree4 xs a b c d Empty =
611 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
612 appendTree4 (Single x) a b c d xs =
613 x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
614 appendTree4 xs a b c d (Single x) =
615 xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
616 appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
617 Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
618
619 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))
620 addDigits4 m1 (One a) b c d e (One f) m2 =
621 appendTree2 m1 (node3 a b c) (node3 d e f) m2
622 addDigits4 m1 (One a) b c d e (Two f g) m2 =
623 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
624 addDigits4 m1 (One a) b c d e (Three f g h) m2 =
625 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
626 addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
627 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
628 addDigits4 m1 (Two a b) c d e f (One g) m2 =
629 appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
630 addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
631 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
632 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
633 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
634 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
635 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
636 addDigits4 m1 (Three a b c) d e f g (One h) m2 =
637 appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
638 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
639 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
640 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
641 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
642 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
643 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
644 addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
645 appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
646 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
647 appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
648 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
649 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
650 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
651 appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
652
653 ------------------------------------------------------------------------
654 -- Deconstruction
655 ------------------------------------------------------------------------
656
657 -- | /O(1)/. Is this the empty sequence?
658 null :: Seq a -> Bool
659 null (Seq Empty) = True
660 null _ = False
661
662 -- | /O(1)/. The number of elements in the sequence.
663 length :: Seq a -> Int
664 length (Seq xs) = size xs
665
666 -- Views
667
668 data Maybe2 a b = Nothing2 | Just2 a b
669
670 -- | View of the left end of a sequence.
671 data ViewL a
672 = EmptyL -- ^ empty sequence
673 | a :< Seq a -- ^ leftmost element and the rest of the sequence
674 #ifndef __HADDOCK__
675 # if __GLASGOW_HASKELL__
676 deriving (Eq, Ord, Show, Read, Data)
677 # else
678 deriving (Eq, Ord, Show, Read)
679 # endif
680 #else
681 instance Eq a => Eq (ViewL a)
682 instance Ord a => Ord (ViewL a)
683 instance Show a => Show (ViewL a)
684 instance Read a => Read (ViewL a)
685 instance Data a => Data (ViewL a)
686 #endif
687
688 INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
689
690 instance Functor ViewL where
691 fmap = fmapDefault
692
693 instance Foldable ViewL where
694 foldr f z EmptyL = z
695 foldr f z (x :< xs) = f x (foldr f z xs)
696
697 foldl f z EmptyL = z
698 foldl f z (x :< xs) = foldl f (f z x) xs
699
700 foldl1 f EmptyL = error "foldl1: empty view"
701 foldl1 f (x :< xs) = foldl f x xs
702
703 instance Traversable ViewL where
704 traverse _ EmptyL = pure EmptyL
705 traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs
706
707 -- | /O(1)/. Analyse the left end of a sequence.
708 viewl :: Seq a -> ViewL a
709 viewl (Seq xs) = case viewLTree xs of
710 Nothing2 -> EmptyL
711 Just2 (Elem x) xs' -> x :< Seq xs'
712
713 {-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}
714 {-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}
715 viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)
716 viewLTree Empty = Nothing2
717 viewLTree (Single a) = Just2 a Empty
718 viewLTree (Deep s (One a) m sf) = Just2 a (case viewLTree m of
719 Nothing2 -> digitToTree sf
720 Just2 b m' -> Deep (s - size a) (nodeToDigit b) m' sf)
721 viewLTree (Deep s (Two a b) m sf) =
722 Just2 a (Deep (s - size a) (One b) m sf)
723 viewLTree (Deep s (Three a b c) m sf) =
724 Just2 a (Deep (s - size a) (Two b c) m sf)
725 viewLTree (Deep s (Four a b c d) m sf) =
726 Just2 a (Deep (s - size a) (Three b c d) m sf)
727
728 -- | View of the right end of a sequence.
729 data ViewR a
730 = EmptyR -- ^ empty sequence
731 | Seq a :> a -- ^ the sequence minus the rightmost element,
732 -- and the rightmost element
733 #ifndef __HADDOCK__
734 # if __GLASGOW_HASKELL__
735 deriving (Eq, Ord, Show, Read, Data)
736 # else
737 deriving (Eq, Ord, Show, Read)
738 # endif
739 #else
740 instance Eq a => Eq (ViewR a)
741 instance Ord a => Ord (ViewR a)
742 instance Show a => Show (ViewR a)
743 instance Read a => Read (ViewR a)
744 instance Data a => Data (ViewR a)
745 #endif
746
747 INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
748
749 instance Functor ViewR where
750 fmap = fmapDefault
751
752 instance Foldable ViewR where
753 foldr f z EmptyR = z
754 foldr f z (xs :> x) = foldr f (f x z) xs
755
756 foldl f z EmptyR = z
757 foldl f z (xs :> x) = f (foldl f z xs) x
758
759 foldr1 f EmptyR = error "foldr1: empty view"
760 foldr1 f (xs :> x) = foldr f x xs
761
762 instance Traversable ViewR where
763 traverse _ EmptyR = pure EmptyR
764 traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x
765
766 -- | /O(1)/. Analyse the right end of a sequence.
767 viewr :: Seq a -> ViewR a
768 viewr (Seq xs) = case viewRTree xs of
769 Nothing2 -> EmptyR
770 Just2 xs' (Elem x) -> Seq xs' :> x
771
772 {-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}
773 {-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}
774 viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a
775 viewRTree Empty = Nothing2
776 viewRTree (Single z) = Just2 Empty z
777 viewRTree (Deep s pr m (One z)) = Just2 (case viewRTree m of
778 Nothing2 -> digitToTree pr
779 Just2 m' y -> Deep (s - size z) pr m' (nodeToDigit y)) z
780 viewRTree (Deep s pr m (Two y z)) =
781 Just2 (Deep (s - size z) pr m (One y)) z
782 viewRTree (Deep s pr m (Three x y z)) =
783 Just2 (Deep (s - size z) pr m (Two x y)) z
784 viewRTree (Deep s pr m (Four w x y z)) =
785 Just2 (Deep (s - size z) pr m (Three w x y)) z
786
787 -- Indexing
788
789 -- | /O(log(min(i,n-i)))/. The element at the specified position
790 index :: Seq a -> Int -> a
791 index (Seq xs) i
792 | 0 <= i && i < size xs = case lookupTree i xs of
793 Place _ (Elem x) -> x
794 | otherwise = error "index out of bounds"
795
796 data Place a = Place {-# UNPACK #-} !Int a
797 #if TESTING
798 deriving Show
799 #endif
800
801 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
802 {-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
803 lookupTree :: Sized a => Int -> FingerTree a -> Place a
804 lookupTree _ Empty = error "lookupTree of empty tree"
805 lookupTree i (Single x) = Place i x
806 lookupTree i (Deep _ pr m sf)
807 | i < spr = lookupDigit i pr
808 | i < spm = case lookupTree (i - spr) m of
809 Place i' xs -> lookupNode i' xs
810 | otherwise = lookupDigit (i - spm) sf
811 where spr = size pr
812 spm = spr + size m
813
814 {-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
815 {-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
816 lookupNode :: Sized a => Int -> Node a -> Place a
817 lookupNode i (Node2 _ a b)
818 | i < sa = Place i a
819 | otherwise = Place (i - sa) b
820 where sa = size a
821 lookupNode i (Node3 _ a b c)
822 | i < sa = Place i a
823 | i < sab = Place (i - sa) b
824 | otherwise = Place (i - sab) c
825 where sa = size a
826 sab = sa + size b
827
828 {-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
829 {-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
830 lookupDigit :: Sized a => Int -> Digit a -> Place a
831 lookupDigit i (One a) = Place i a
832 lookupDigit i (Two a b)
833 | i < sa = Place i a
834 | otherwise = Place (i - sa) b
835 where sa = size a
836 lookupDigit i (Three a b c)
837 | i < sa = Place i a
838 | i < sab = Place (i - sa) b
839 | otherwise = Place (i - sab) c
840 where sa = size a
841 sab = sa + size b
842 lookupDigit i (Four a b c d)
843 | i < sa = Place i a
844 | i < sab = Place (i - sa) b
845 | i < sabc = Place (i - sab) c
846 | otherwise = Place (i - sabc) d
847 where sa = size a
848 sab = sa + size b
849 sabc = sab + size c
850
851 -- | /O(log(min(i,n-i)))/. Replace the element at the specified position
852 update :: Int -> a -> Seq a -> Seq a
853 update i x = adjust (const x) i
854
855 -- | /O(log(min(i,n-i)))/. Update the element at the specified position
856 adjust :: (a -> a) -> Int -> Seq a -> Seq a
857 adjust f i (Seq xs)
858 | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)
859 | otherwise = Seq xs
860
861 {-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
862 {-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
863 adjustTree :: Sized a => (Int -> a -> a) ->
864 Int -> FingerTree a -> FingerTree a
865 adjustTree _ _ Empty = error "adjustTree of empty tree"
866 adjustTree f i (Single x) = Single (f i x)
867 adjustTree f i (Deep s pr m sf)
868 | i < spr = Deep s (adjustDigit f i pr) m sf
869 | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf
870 | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
871 where spr = size pr
872 spm = spr + size m
873
874 {-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
875 {-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
876 adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a
877 adjustNode f i (Node2 s a b)
878 | i < sa = Node2 s (f i a) b
879 | otherwise = Node2 s a (f (i - sa) b)
880 where sa = size a
881 adjustNode f i (Node3 s a b c)
882 | i < sa = Node3 s (f i a) b c
883 | i < sab = Node3 s a (f (i - sa) b) c
884 | otherwise = Node3 s a b (f (i - sab) c)
885 where sa = size a
886 sab = sa + size b
887
888 {-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
889 {-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
890 adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a
891 adjustDigit f i (One a) = One (f i a)
892 adjustDigit f i (Two a b)
893 | i < sa = Two (f i a) b
894 | otherwise = Two a (f (i - sa) b)
895 where sa = size a
896 adjustDigit f i (Three a b c)
897 | i < sa = Three (f i a) b c
898 | i < sab = Three a (f (i - sa) b) c
899 | otherwise = Three a b (f (i - sab) c)
900 where sa = size a
901 sab = sa + size b
902 adjustDigit f i (Four a b c d)
903 | i < sa = Four (f i a) b c d
904 | i < sab = Four a (f (i - sa) b) c d
905 | i < sabc = Four a b (f (i - sab) c) d
906 | otherwise = Four a b c (f (i- sabc) d)
907 where sa = size a
908 sab = sa + size b
909 sabc = sab + size c
910
911 -- Splitting
912
913 -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.
914 take :: Int -> Seq a -> Seq a
915 take i = fst . splitAt i
916
917 -- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.
918 drop :: Int -> Seq a -> Seq a
919 drop i = snd . splitAt i
920
921 -- | /O(log(min(i,n-i)))/. Split a sequence at a given position.
922 splitAt :: Int -> Seq a -> (Seq a, Seq a)
923 splitAt i (Seq xs) = (Seq l, Seq r)
924 where (l, r) = split i xs
925
926 split :: Int -> FingerTree (Elem a) ->
927 (FingerTree (Elem a), FingerTree (Elem a))
928 split i Empty = i `seq` (Empty, Empty)
929 split i xs
930 | size xs > i = (l, consTree x r)
931 | otherwise = (xs, Empty)
932 where Split l x r = splitTree i xs
933
934 data Split t a = Split t a t
935 #if TESTING
936 deriving Show
937 #endif
938
939 {-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}
940 {-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}
941 splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a
942 splitTree _ Empty = error "splitTree of empty tree"
943 splitTree i (Single x) = i `seq` Split Empty x Empty
944 splitTree i (Deep _ pr m sf)
945 | i < spr = case splitDigit i pr of
946 Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)
947 | i < spm = case splitTree im m of
948 Split ml xs mr -> case splitNode (im - size ml) xs of
949 Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)
950 | otherwise = case splitDigit (i - spm) sf of
951 Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)
952 where spr = size pr
953 spm = spr + size m
954 im = i - spr
955
956 {-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
957 {-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
958 deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a
959 deepL Nothing m sf = case viewLTree m of
960 Nothing2 -> digitToTree sf
961 Just2 a m' -> deep (nodeToDigit a) m' sf
962 deepL (Just pr) m sf = deep pr m sf
963
964 {-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}
965 {-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}
966 deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a
967 deepR pr m Nothing = case viewRTree m of
968 Nothing2 -> digitToTree pr
969 Just2 m' a -> deep pr m' (nodeToDigit a)
970 deepR pr m (Just sf) = deep pr m sf
971
972 {-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
973 {-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
974 splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a
975 splitNode i (Node2 _ a b)
976 | i < sa = Split Nothing a (Just (One b))
977 | otherwise = Split (Just (One a)) b Nothing
978 where sa = size a
979 splitNode i (Node3 _ a b c)
980 | i < sa = Split Nothing a (Just (Two b c))
981 | i < sab = Split (Just (One a)) b (Just (One c))
982 | otherwise = Split (Just (Two a b)) c Nothing
983 where sa = size a
984 sab = sa + size b
985
986 {-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}
987 {-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}
988 splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a
989 splitDigit i (One a) = i `seq` Split Nothing a Nothing
990 splitDigit i (Two a b)
991 | i < sa = Split Nothing a (Just (One b))
992 | otherwise = Split (Just (One a)) b Nothing
993 where sa = size a
994 splitDigit i (Three a b c)
995 | i < sa = Split Nothing a (Just (Two b c))
996 | i < sab = Split (Just (One a)) b (Just (One c))
997 | otherwise = Split (Just (Two a b)) c Nothing
998 where sa = size a
999 sab = sa + size b
1000 splitDigit i (Four a b c d)
1001 | i < sa = Split Nothing a (Just (Three b c d))
1002 | i < sab = Split (Just (One a)) b (Just (Two c d))
1003 | i < sabc = Split (Just (Two a b)) c (Just (One d))
1004 | otherwise = Split (Just (Three a b c)) d Nothing
1005 where sa = size a
1006 sab = sa + size b
1007 sabc = sab + size c
1008
1009 ------------------------------------------------------------------------
1010 -- Lists
1011 ------------------------------------------------------------------------
1012
1013 -- | /O(n)/. Create a sequence from a finite list of elements.
1014 -- There is a function 'toList' in the opposite direction for all
1015 -- instances of the 'Foldable' class, including 'Seq'.
1016 fromList :: [a] -> Seq a
1017 fromList = Data.List.foldl' (|>) empty
1018
1019 ------------------------------------------------------------------------
1020 -- Reverse
1021 ------------------------------------------------------------------------
1022
1023 -- | /O(n)/. The reverse of a sequence.
1024 reverse :: Seq a -> Seq a
1025 reverse (Seq xs) = Seq (reverseTree id xs)
1026
1027 reverseTree :: (a -> a) -> FingerTree a -> FingerTree a
1028 reverseTree _ Empty = Empty
1029 reverseTree f (Single x) = Single (f x)
1030 reverseTree f (Deep s pr m sf) =
1031 Deep s (reverseDigit f sf)
1032 (reverseTree (reverseNode f) m)
1033 (reverseDigit f pr)
1034
1035 reverseDigit :: (a -> a) -> Digit a -> Digit a
1036 reverseDigit f (One a) = One (f a)
1037 reverseDigit f (Two a b) = Two (f b) (f a)
1038 reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
1039 reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
1040
1041 reverseNode :: (a -> a) -> Node a -> Node a
1042 reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
1043 reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
1044
1045 #if TESTING
1046
1047 ------------------------------------------------------------------------
1048 -- QuickCheck
1049 ------------------------------------------------------------------------
1050
1051 instance Arbitrary a => Arbitrary (Seq a) where
1052 arbitrary = liftM Seq arbitrary
1053 coarbitrary (Seq x) = coarbitrary x
1054
1055 instance Arbitrary a => Arbitrary (Elem a) where
1056 arbitrary = liftM Elem arbitrary
1057 coarbitrary (Elem x) = coarbitrary x
1058
1059 instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
1060 arbitrary = sized arb
1061 where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)
1062 arb 0 = return Empty
1063 arb 1 = liftM Single arbitrary
1064 arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary
1065
1066 coarbitrary Empty = variant 0
1067 coarbitrary (Single x) = variant 1 . coarbitrary x
1068 coarbitrary (Deep _ pr m sf) =
1069 variant 2 . coarbitrary pr . coarbitrary m . coarbitrary sf
1070
1071 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
1072 arbitrary = oneof [
1073 liftM2 node2 arbitrary arbitrary,
1074 liftM3 node3 arbitrary arbitrary arbitrary]
1075
1076 coarbitrary (Node2 _ a b) = variant 0 . coarbitrary a . coarbitrary b
1077 coarbitrary (Node3 _ a b c) =
1078 variant 1 . coarbitrary a . coarbitrary b . coarbitrary c
1079
1080 instance Arbitrary a => Arbitrary (Digit a) where
1081 arbitrary = oneof [
1082 liftM One arbitrary,
1083 liftM2 Two arbitrary arbitrary,
1084 liftM3 Three arbitrary arbitrary arbitrary,
1085 liftM4 Four arbitrary arbitrary arbitrary arbitrary]
1086
1087 coarbitrary (One a) = variant 0 . coarbitrary a
1088 coarbitrary (Two a b) = variant 1 . coarbitrary a . coarbitrary b
1089 coarbitrary (Three a b c) =
1090 variant 2 . coarbitrary a . coarbitrary b . coarbitrary c
1091 coarbitrary (Four a b c d) =
1092 variant 3 . coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
1093
1094 ------------------------------------------------------------------------
1095 -- Valid trees
1096 ------------------------------------------------------------------------
1097
1098 class Valid a where
1099 valid :: a -> Bool
1100
1101 instance Valid (Elem a) where
1102 valid _ = True
1103
1104 instance Valid (Seq a) where
1105 valid (Seq xs) = valid xs
1106
1107 instance (Sized a, Valid a) => Valid (FingerTree a) where
1108 valid Empty = True
1109 valid (Single x) = valid x
1110 valid (Deep s pr m sf) =
1111 s == size pr + size m + size sf && valid pr && valid m && valid sf
1112
1113 instance (Sized a, Valid a) => Valid (Node a) where
1114 valid (Node2 s a b) = s == size a + size b && valid a && valid b
1115 valid (Node3 s a b c) =
1116 s == size a + size b + size c && valid a && valid b && valid c
1117
1118 instance Valid a => Valid (Digit a) where
1119 valid (One a) = valid a
1120 valid (Two a b) = valid a && valid b
1121 valid (Three a b c) = valid a && valid b && valid c
1122 valid (Four a b c d) = valid a && valid b && valid c && valid d
1123
1124 #endif