Data/Sequence.hs

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