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