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