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