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