{-# LANGUAGE CPP #-}
#include "containers.h"
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
#endif
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Trustworthy #-}
#endif
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric #-}
#endif
#ifdef DEFINE_PATTERN_SYNONYMS
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
#endif
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_HADDOCK not-home #-}
module Data.Sequence.Internal (
Elem(..), FingerTree(..), Node(..), Digit(..), Sized(..), MaybeForce,
#if defined(DEFINE_PATTERN_SYNONYMS)
Seq (.., Empty, (:<|), (:|>)),
#else
Seq (..),
#endif
State(..),
execState,
foldDigit,
foldNode,
foldWithIndexDigit,
foldWithIndexNode,
empty,
singleton,
(<|),
(|>),
(><),
fromList,
fromFunction,
fromArray,
replicate,
replicateA,
replicateM,
cycleTaking,
iterateN,
unfoldr,
unfoldl,
null,
length,
ViewL(..),
viewl,
ViewR(..),
viewr,
scanl,
scanl1,
scanr,
scanr1,
tails,
inits,
chunksOf,
takeWhileL,
takeWhileR,
dropWhileL,
dropWhileR,
spanl,
spanr,
breakl,
breakr,
partition,
filter,
lookup,
(!?),
index,
adjust,
adjust',
update,
take,
drop,
insertAt,
deleteAt,
splitAt,
elemIndexL,
elemIndicesL,
elemIndexR,
elemIndicesR,
findIndexL,
findIndicesL,
findIndexR,
findIndicesR,
foldMapWithIndex,
foldlWithIndex,
foldrWithIndex,
mapWithIndex,
traverseWithIndex,
reverse,
intersperse,
liftA2Seq,
zip,
zipWith,
zip3,
zipWith3,
zip4,
zipWith4,
unzip,
unzipWith,
#ifdef TESTING
deep,
node2,
node3,
#endif
) where
import Prelude hiding (
Functor(..),
#if MIN_VERSION_base(4,11,0)
(<>),
#endif
#if MIN_VERSION_base(4,8,0)
Applicative, (<$>), foldMap, Monoid,
#endif
null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
import qualified Data.List
import Control.Applicative (Applicative(..), (<$>), (<**>), Alternative,
liftA2, liftA3)
import qualified Control.Applicative as Applicative
import Control.DeepSeq (NFData(rnf))
import Control.Monad (MonadPlus(..))
import Data.Monoid (Monoid(..))
import Data.Functor (Functor(..))
import Utils.Containers.Internal.State (State(..), execState)
#if MIN_VERSION_base(4,6,0)
import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList)
#else
import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap), foldl', toList)
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Semigroup
import Data.Functor.Classes
#endif
import Data.Traversable
import Data.Typeable
#ifdef __GLASGOW_HASKELL__
import GHC.Exts (build)
import Text.Read (Lexeme(Ident), lexP, parens, prec,
readPrec, readListPrec, readListPrecDefault)
import Data.Data
import Data.String (IsString(..))
#endif
#if __GLASGOW_HASKELL__ >= 706
import GHC.Generics (Generic, Generic1)
#elif __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic)
#endif
import Data.Array (Ix, Array)
import qualified Data.Array
#ifdef __GLASGOW_HASKELL__
import qualified GHC.Arr
#endif
#if __GLASGOW_HASKELL__ >= 708
import Data.Coerce
import qualified GHC.Exts
#else
#endif
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity(..))
#endif
#if !MIN_VERSION_base(4,8,0)
import Data.Word (Word)
#endif
import Utils.Containers.Internal.StrictPair (StrictPair (..), toPair)
#if MIN_VERSION_base(4,4,0)
import Control.Monad.Zip (MonadZip (..))
#endif
import Control.Monad.Fix (MonadFix (..), fix)
default ()
infixr 6 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
{-# INLINE (<>) #-}
infixr 5 `consTree`
infixl 5 `snocTree`
infixr 5 `appendTree0`
infixr 5 ><
infixr 5 <|, :<
infixl 5 |>, :>
#ifdef DEFINE_PATTERN_SYNONYMS
infixr 5 :<|
infixl 5 :|>
#if __GLASGOW_HASKELL__ >= 801
{-# COMPLETE (:<|), Empty #-}
{-# COMPLETE (:|>), Empty #-}
#endif
pattern Empty :: Seq a
pattern Empty = Seq EmptyT
pattern (:<|) :: a -> Seq a -> Seq a
pattern x :<| xs <- (viewl -> x :< xs)
where
x :<| xs = x <| xs
pattern (:|>) :: Seq a -> a -> Seq a
pattern xs :|> x <- (viewr -> xs :> x)
where
xs :|> x = xs |> x
#endif
class Sized a where
size :: a -> Int
class MaybeForce a where
maybeRwhnf :: a -> ()
mseq :: MaybeForce a => a -> b -> b
mseq a b = case maybeRwhnf a of () -> b
{-# INLINE mseq #-}
infixr 0 $!?
($!?) :: MaybeForce a => (a -> b) -> a -> b
f $!? a = case maybeRwhnf a of () -> f a
{-# INLINE ($!?) #-}
instance MaybeForce (Elem a) where
maybeRwhnf _ = ()
{-# INLINE maybeRwhnf #-}
instance MaybeForce (Node a) where
maybeRwhnf !_ = ()
{-# INLINE maybeRwhnf #-}
newtype ForceBox a = ForceBox a
instance MaybeForce (ForceBox a) where
maybeRwhnf !_ = ()
instance Sized (ForceBox a) where
size _ = 1
newtype Seq a = Seq (FingerTree (Elem a))
instance Functor Seq where
fmap = fmapSeq
#ifdef __GLASGOW_HASKELL__
x <$ s = replicate (length s) x
#endif
fmapSeq :: (a -> b) -> Seq a -> Seq b
fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
#ifdef __GLASGOW_HASKELL__
{-# NOINLINE [1] fmapSeq #-}
{-# RULES
"fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs
#-}
#endif
#if __GLASGOW_HASKELL__ >= 709
{-# RULES
"fmapSeq/coerce" fmapSeq coerce = coerce
#-}
#endif
instance Foldable Seq where
foldMap f (Seq xs) = foldMap (foldMap f) xs
#if __GLASGOW_HASKELL__ >= 708
foldr f z (Seq xs) = foldr (coerce f) z xs
foldr' f z (Seq xs) = foldr' (coerce f) z xs
#else
foldr f z (Seq xs) = foldr (flip (foldr f)) z xs
#if MIN_VERSION_base(4,6,0)
foldr' f z (Seq xs) = foldr' (flip (foldr' f)) z xs
#endif
#endif
foldl f z (Seq xs) = foldl (foldl f) z xs
#if MIN_VERSION_base(4,6,0)
foldl' f z (Seq xs) = foldl' (foldl' f) z xs
#endif
foldr1 f (Seq xs) = getElem (foldr1 f' xs)
where f' (Elem x) (Elem y) = Elem (f x y)
foldl1 f (Seq xs) = getElem (foldl1 f' xs)
where f' (Elem x) (Elem y) = Elem (f x y)
#if MIN_VERSION_base(4,8,0)
length = length
{-# INLINE length #-}
null = null
{-# INLINE null #-}
#endif
#if __GLASGOW_HASKELL__ >= 708
instance Traversable Seq where
traverse f xs = traverseFTE f (coerce xs)
traverseFTE :: Applicative f => (a -> f b) -> FingerTree a -> f (Seq b)
traverseFTE _f EmptyT = pure empty
traverseFTE f (Single x) = Seq . Single . Elem <$> f x
traverseFTE f (Deep s pr m sf) =
liftA3 (\pr' m' sf' -> coerce $ Deep s pr' m' sf')
(traverse f pr) (traverse (traverse f) m) (traverse f sf)
#else
instance Traversable Seq where
traverse f (Seq xs) = Seq <$> traverse (traverse f) xs
#endif
instance NFData a => NFData (Seq a) where
rnf (Seq xs) = rnf xs
instance Monad Seq where
return = pure
xs >>= f = foldl' add empty xs
where add ys x = ys >< f x
(>>) = (*>)
instance MonadFix Seq where
mfix = mfixSeq
mfixSeq :: (a -> Seq a) -> Seq a
mfixSeq f = fromFunction (length (f err)) (\k -> fix (\xk -> f xk `index` k))
where
err = error "mfix for Data.Sequence.Seq applied to strict function"
instance Applicative Seq where
pure = singleton
xs *> ys = cycleNTimes (length xs) ys
(<*>) = apSeq
#if MIN_VERSION_base(4,10,0)
liftA2 = liftA2Seq
#endif
apSeq :: Seq (a -> b) -> Seq a -> Seq b
apSeq fs xs@(Seq xsFT) = case viewl fs of
EmptyL -> empty
firstf :< fs' -> case viewr fs' of
EmptyR -> fmap firstf xs
Seq fs''FT :> lastf -> case rigidify xsFT of
RigidEmpty -> empty
RigidOne (Elem x) -> fmap ($x) fs
RigidTwo (Elem x1) (Elem x2) ->
Seq $ ap2FT firstf fs''FT lastf (x1, x2)
RigidThree (Elem x1) (Elem x2) (Elem x3) ->
Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)
RigidFull r@(Rigid s pr _m sf) -> Seq $
Deep (s * length fs)
(fmap (fmap firstf) (nodeToDigit pr))
(aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)
(fmap (fmap lastf) (nodeToDigit sf))
{-# NOINLINE [1] apSeq #-}
{-# RULES
"ap/fmap1" forall f xs ys . apSeq (fmapSeq f xs) ys = liftA2Seq f xs ys
"ap/fmap2" forall f gs xs . apSeq gs (fmapSeq f xs) =
liftA2Seq (\g x -> g (f x)) gs xs
"fmap/ap" forall f gs xs . fmapSeq f (gs `apSeq` xs) =
liftA2Seq (\g x -> f (g x)) gs xs
"fmap/liftA2" forall f g m n . fmapSeq f (liftA2Seq g m n) =
liftA2Seq (\x y -> f (g x y)) m n
"liftA2/fmap1" forall f g m n . liftA2Seq f (fmapSeq g m) n =
liftA2Seq (\x y -> f (g x) y) m n
"liftA2/fmap2" forall f g m n . liftA2Seq f m (fmapSeq g n) =
liftA2Seq (\x y -> f x (g y)) m n
#-}
ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)
ap2FT firstf fs lastf (x,y) =
Deep (size fs * 2 + 4)
(Two (Elem $ firstf x) (Elem $ firstf y))
(mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs)
(Two (Elem $ lastf x) (Elem $ lastf y))
ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)
ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6)
(Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))
(mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs)
(Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))
lift2FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b) -> FingerTree (Elem c)
lift2FT f firstx xs lastx (y1,y2) =
Deep (size xs * 2 + 4)
(Two (Elem $ f firstx y1) (Elem $ f firstx y2))
(mapMulFT 2 (\(Elem x) -> Node2 2 (Elem (f x y1)) (Elem (f x y2))) xs)
(Two (Elem $ f lastx y1) (Elem $ f lastx y2))
lift3FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b,b) -> FingerTree (Elem c)
lift3FT f firstx xs lastx (y1,y2,y3) =
Deep (size xs * 3 + 6)
(Three (Elem $ f firstx y1) (Elem $ f firstx y2) (Elem $ f firstx y3))
(mapMulFT 3 (\(Elem x) -> Node3 3 (Elem (f x y1)) (Elem (f x y2)) (Elem (f x y3))) xs)
(Three (Elem $ f lastx y1) (Elem $ f lastx y2) (Elem $ f lastx y3))
liftA2Seq :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
liftA2Seq f xs ys@(Seq ysFT) = case viewl xs of
EmptyL -> empty
firstx :< xs' -> case viewr xs' of
EmptyR -> f firstx <$> ys
Seq xs''FT :> lastx -> case rigidify ysFT of
RigidEmpty -> empty
RigidOne (Elem y) -> fmap (\x -> f x y) xs
RigidTwo (Elem y1) (Elem y2) ->
Seq $ lift2FT f firstx xs''FT lastx (y1, y2)
RigidThree (Elem y1) (Elem y2) (Elem y3) ->
Seq $ lift3FT f firstx xs''FT lastx (y1, y2, y3)
RigidFull r@(Rigid s pr _m sf) -> Seq $
Deep (s * length xs)
(fmap (fmap (f firstx)) (nodeToDigit pr))
(aptyMiddle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r)
(fmap (fmap (f lastx)) (nodeToDigit sf))
where
lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c
#if __GLASGOW_HASKELL__ >= 708
lift_elem = coerce
#else
lift_elem f x (Elem y) = Elem (f x y)
#endif
{-# NOINLINE [1] liftA2Seq #-}
data Rigidified a = RigidEmpty
| RigidOne a
| RigidTwo a a
| RigidThree a a a
| RigidFull (Rigid a)
#ifdef TESTING
deriving Show
#endif
data Rigid a = Rigid {-# UNPACK #-} !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)
#ifdef TESTING
deriving Show
#endif
data Thin a = EmptyTh
| SingleTh a
| DeepTh {-# UNPACK #-} !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)
#ifdef TESTING
deriving Show
#endif
data Digit12 a = One12 a | Two12 a a
#ifdef TESTING
deriving Show
#endif
type Digit23 a = Node a
aptyMiddle
:: (b -> c)
-> (b -> c)
-> (a -> b -> c)
-> FingerTree (Elem a)
-> Rigid b
-> FingerTree (Node c)
aptyMiddle firstf
lastf
map23
fs
(Rigid s pr (DeepTh sm prm mm sfm) sf)
= Deep (sm + s * (size fs + 1))
(fmap (fmap firstf) (digit12ToDigit prm))
(aptyMiddle (fmap firstf)
(fmap lastf)
(fmap . map23)
fs
(Rigid s (squashL pr prm) mm (squashR sfm sf)))
(fmap (fmap lastf) (digit12ToDigit sfm))
aptyMiddle firstf
lastf
map23
fs
(Rigid s pr EmptyTh sf)
= deep
(One (fmap firstf sf))
(mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
(One (fmap lastf pr))
where converted = node2 pr sf
aptyMiddle firstf
lastf
map23
fs
(Rigid s pr (SingleTh q) sf)
= deep
(Two (fmap firstf q) (fmap firstf sf))
(mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
(Two (fmap lastf pr) (fmap lastf q))
where converted = node3 pr q sf
digit12ToDigit :: Digit12 a -> Digit a
digit12ToDigit (One12 a) = One a
digit12ToDigit (Two12 a b) = Two a b
squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)
squashL m (One12 n) = node2 m n
squashL m (Two12 n1 n2) = node3 m n1 n2
squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)
squashR (One12 n) m = node2 n m
squashR (Two12 n1 n2) m = node3 n1 n2 m
mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b
mapMulFT _ _ EmptyT = EmptyT
mapMulFT _mul f (Single a) = Single (f a)
mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)
mapMulNode :: Int -> (a -> b) -> Node a -> Node b
mapMulNode mul f (Node2 s a b) = Node2 (mul * s) (f a) (f b)
mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)
rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)
rigidify EmptyT = RigidEmpty
rigidify (Single q) = RigidOne q
rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf
rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf
rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf
rigidify (Deep s (One a) m sf) = case viewLTree m of
ConsLTree (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf
ConsLTree (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf
EmptyLTree -> case sf of
One b -> RigidTwo a b
Two b c -> RigidThree a b c
Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)
Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)
rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)
rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)
rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)
rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)
rigidifyRight s pr m (One e) = case viewRTree m of
SnocRTree m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)
SnocRTree m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)
EmptyRTree -> case pr of
Node2 _ a b -> RigidThree a b e
Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)
thin :: Sized a => FingerTree a -> Thin a
thin EmptyT = EmptyTh
thin (Single a) = SingleTh a
thin (Deep s pr m sf) =
case pr of
One a -> thin12 s (One12 a) m sf
Two a b -> thin12 s (Two12 a b) m sf
Three a b c -> thin12 s (One12 a) (node2 b c `consTree` m) sf
Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf
thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a
thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)
thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)
thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)
thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d)
intersperse :: a -> Seq a -> Seq a
intersperse y xs = case viewl xs of
EmptyL -> empty
p :< ps -> p <| (ps <**> (const y <| singleton id))
instance MonadPlus Seq where
mzero = empty
mplus = (><)
instance Alternative Seq where
empty = empty
(<|>) = (><)
instance Eq a => Eq (Seq a) where
xs == ys = length xs == length ys && toList xs == toList ys
instance Ord a => Ord (Seq a) where
compare xs ys = compare (toList xs) (toList ys)
#ifdef TESTING
instance Show a => Show (Seq a) where
showsPrec p (Seq x) = showsPrec p x
#else
instance Show a => Show (Seq a) where
showsPrec p xs = showParen (p > 10) $
showString "fromList " . shows (toList xs)
#endif
#if MIN_VERSION_base(4,9,0)
instance Show1 Seq where
liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $
showString "fromList " . shwList (toList xs)
instance Eq1 Seq where
liftEq eq xs ys = length xs == length ys && liftEq eq (toList xs) (toList ys)
instance Ord1 Seq where
liftCompare cmp xs ys = liftCompare cmp (toList xs) (toList ys)
#endif
instance Read a => Read (Seq a) where
#ifdef __GLASGOW_HASKELL__
readPrec = parens $ prec 10 $ do
Ident "fromList" <- lexP
xs <- readPrec
return (fromList xs)
readListPrec = readListPrecDefault
#else
readsPrec p = readParen (p > 10) $ \ r -> do
("fromList",s) <- lex r
(xs,t) <- reads s
return (fromList xs,t)
#endif
#if MIN_VERSION_base(4,9,0)
instance Read1 Seq where
liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do
("fromList",s) <- lex r
(xs,t) <- readLst s
pure (fromList xs, t)
#endif
instance Monoid (Seq a) where
mempty = empty
mappend = (><)
#if MIN_VERSION_base(4,9,0)
instance Semigroup.Semigroup (Seq a) where
(<>) = (><)
#endif
INSTANCE_TYPEABLE1(Seq)
#if __GLASGOW_HASKELL__
instance Data a => Data (Seq a) where
gfoldl f z s = case viewl s of
EmptyL -> z empty
x :< xs -> z (<|) `f` x `f` xs
gunfold k z c = case constrIndex c of
1 -> z empty
2 -> k (k (z (<|)))
_ -> error "gunfold"
toConstr xs
| null xs = emptyConstr
| otherwise = consConstr
dataTypeOf _ = seqDataType
dataCast1 f = gcast1 f
emptyConstr, consConstr :: Constr
emptyConstr = mkConstr seqDataType "empty" [] Prefix
consConstr = mkConstr seqDataType "<|" [] Infix
seqDataType :: DataType
seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
#endif
data FingerTree a
= EmptyT
| Single a
| Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
#ifdef TESTING
deriving Show
#endif
instance Sized a => Sized (FingerTree a) where
{-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
{-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
size EmptyT = 0
size (Single x) = size x
size (Deep v _ _ _) = v
instance Foldable FingerTree where
foldMap _ EmptyT = mempty
foldMap f (Single x) = f x
foldMap f (Deep _ pr m sf) =
foldMap f pr <> foldMap (foldMap f) m <> foldMap f sf
foldr _ z EmptyT = z
foldr f z (Single x) = x `f` z
foldr f z (Deep _ pr m sf) =
foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr
foldl _ z EmptyT = z
foldl f z (Single x) = z `f` x
foldl f z (Deep _ pr m sf) =
foldl f (foldl (foldl f) (foldl f z pr) m) sf
#if MIN_VERSION_base(4,6,0)
foldr' _ z EmptyT = z
foldr' f z (Single x) = f x z
foldr' f z (Deep _ pr m sf) = foldr' f mres pr
where !sfRes = foldr' f z sf
!mres = foldr' (flip (foldr' f)) sfRes m
foldl' _ z EmptyT = z
foldl' f z (Single x) = z `f` x
foldl' f z (Deep _ pr m sf) = foldl' f mres sf
where !prRes = foldl' f z pr
!mres = foldl' (foldl' f) prRes m
#endif
foldr1 _ EmptyT = error "foldr1: empty sequence"
foldr1 _ (Single x) = x
foldr1 f (Deep _ pr m sf) =
foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr
foldl1 _ EmptyT = error "foldl1: empty sequence"
foldl1 _ (Single x) = x
foldl1 f (Deep _ pr m sf) =
foldl f (foldl (foldl f) (foldl1 f pr) m) sf
instance Functor FingerTree where
fmap _ EmptyT = EmptyT
fmap f (Single x) = Single (f x)
fmap f (Deep v pr m sf) =
Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
instance Traversable FingerTree where
traverse _ EmptyT = pure EmptyT
traverse f (Single x) = Single <$> f x
traverse f (Deep v pr m sf) =
liftA3 (Deep v) (traverse f pr) (traverse (traverse f) m)
(traverse f sf)
instance NFData a => NFData (FingerTree a) where
rnf EmptyT = ()
rnf (Single x) = rnf x
rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m
{-# INLINE deep #-}
deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
deep pr m sf = Deep (size pr + size m + size sf) pr m sf
{-# INLINE pullL #-}
pullL :: Int -> FingerTree (Node a) -> Digit a -> FingerTree a
pullL s m sf = case viewLTree m of
EmptyLTree -> digitToTree' s sf
ConsLTree pr m' -> Deep s (nodeToDigit pr) m' sf
{-# INLINE pullR #-}
pullR :: Int -> Digit a -> FingerTree (Node a) -> FingerTree a
pullR s pr m = case viewRTree m of
EmptyRTree -> digitToTree' s pr
SnocRTree m' sf -> Deep s pr m' (nodeToDigit sf)
data Digit a
= One a
| Two a a
| Three a a a
| Four a a a a
#ifdef TESTING
deriving Show
#endif
foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
foldDigit _ f (One a) = f a
foldDigit (<+>) f (Two a b) = f a <+> f b
foldDigit (<+>) f (Three a b c) = f a <+> f b <+> f c
foldDigit (<+>) f (Four a b c d) = f a <+> f b <+> f c <+> f d
{-# INLINE foldDigit #-}
instance Foldable Digit where
foldMap = foldDigit mappend
foldr f z (One a) = a `f` z
foldr f z (Two a b) = a `f` (b `f` z)
foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
foldl f z (One a) = z `f` a
foldl f z (Two a b) = (z `f` a) `f` b
foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
#if MIN_VERSION_base(4,6,0)
foldr' f z (One a) = a `f` z
foldr' f z (Two a b) = f a $! f b z
foldr' f z (Three a b c) = f a $! f b $! f c z
foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z
foldl' f z (One a) = f z a
foldl' f z (Two a b) = (f $! f z a) b
foldl' f z (Three a b c) = (f $! (f $! f z a) b) c
foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d
#endif
foldr1 _ (One a) = a
foldr1 f (Two a b) = a `f` b
foldr1 f (Three a b c) = a `f` (b `f` c)
foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))
foldl1 _ (One a) = a
foldl1 f (Two a b) = a `f` b
foldl1 f (Three a b c) = (a `f` b) `f` c
foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d
instance Functor Digit where
{-# INLINE fmap #-}
fmap f (One a) = One (f a)
fmap f (Two a b) = Two (f a) (f b)
fmap f (Three a b c) = Three (f a) (f b) (f c)
fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
instance Traversable Digit where
{-# INLINE traverse #-}
traverse f (One a) = One <$> f a
traverse f (Two a b) = liftA2 Two (f a) (f b)
traverse f (Three a b c) = liftA3 Three (f a) (f b) (f c)
traverse f (Four a b c d) = liftA3 Four (f a) (f b) (f c) <*> f d
instance NFData a => NFData (Digit a) where
rnf (One a) = rnf a
rnf (Two a b) = rnf a `seq` rnf b
rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c
rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
instance Sized a => Sized (Digit a) where
{-# INLINE size #-}
size = foldl1 (+) . fmap size
{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
digitToTree :: Sized a => Digit a -> FingerTree a
digitToTree (One a) = Single a
digitToTree (Two a b) = deep (One a) EmptyT (One b)
digitToTree (Three a b c) = deep (Two a b) EmptyT (One c)
digitToTree (Four a b c d) = deep (Two a b) EmptyT (Two c d)
digitToTree' :: Int -> Digit a -> FingerTree a
digitToTree' n (Four a b c d) = Deep n (Two a b) EmptyT (Two c d)
digitToTree' n (Three a b c) = Deep n (Two a b) EmptyT (One c)
digitToTree' n (Two a b) = Deep n (One a) EmptyT (One b)
digitToTree' !_n (One a) = Single a
data Node a
= Node2 {-# UNPACK #-} !Int a a
| Node3 {-# UNPACK #-} !Int a a a
#ifdef TESTING
deriving Show
#endif
foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b
foldNode (<+>) f (Node2 _ a b) = f a <+> f b
foldNode (<+>) f (Node3 _ a b c) = f a <+> f b <+> f c
{-# INLINE foldNode #-}
instance Foldable Node where
foldMap = foldNode mappend
foldr f z (Node2 _ a b) = a `f` (b `f` z)
foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
foldl f z (Node2 _ a b) = (z `f` a) `f` b
foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
#if MIN_VERSION_base(4,6,0)
foldr' f z (Node2 _ a b) = f a $! f b z
foldr' f z (Node3 _ a b c) = f a $! f b $! f c z
foldl' f z (Node2 _ a b) = (f $! f z a) b
foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c
#endif
instance Functor Node where
{-# INLINE fmap #-}
fmap f (Node2 v a b) = Node2 v (f a) (f b)
fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
instance Traversable Node where
{-# INLINE traverse #-}
traverse f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)
traverse f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c)
instance NFData a => NFData (Node a) where
rnf (Node2 _ a b) = rnf a `seq` rnf b
rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c
instance Sized (Node a) where
size (Node2 v _ _) = v
size (Node3 v _ _ _) = v
{-# INLINE node2 #-}
node2 :: Sized a => a -> a -> Node a
node2 a b = Node2 (size a + size b) a b
{-# INLINE node3 #-}
node3 :: Sized a => a -> a -> a -> Node a
node3 a b c = Node3 (size a + size b + size c) a b c
nodeToDigit :: Node a -> Digit a
nodeToDigit (Node2 _ a b) = Two a b
nodeToDigit (Node3 _ a b c) = Three a b c
newtype Elem a = Elem { getElem :: a }
#ifdef TESTING
deriving Show
#endif
instance Sized (Elem a) where
size _ = 1
instance Functor Elem where
#if __GLASGOW_HASKELL__ >= 708
fmap = coerce
#else
fmap f (Elem x) = Elem (f x)
#endif
instance Foldable Elem where
foldr f z (Elem x) = f x z
#if __GLASGOW_HASKELL__ >= 708
foldMap = coerce
foldl = coerce
foldl' = coerce
#else
foldMap f (Elem x) = f x
foldl f z (Elem x) = f z x
#if MIN_VERSION_base(4,6,0)
foldl' f z (Elem x) = f z x
#endif
#endif
instance Traversable Elem where
traverse f (Elem x) = Elem <$> f x
instance NFData a => NFData (Elem a) where
rnf (Elem x) = rnf x
#if !MIN_VERSION_base(4,8,0)
newtype Identity a = Identity {runIdentity :: a}
instance Functor Identity where
fmap f (Identity x) = Identity (f x)
instance Applicative Identity where
pure = Identity
Identity f <*> Identity x = Identity (f x)
#endif
{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
{-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}
applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
applicativeTree n !mSize m = case n of
0 -> pure EmptyT
1 -> fmap Single m
2 -> deepA one emptyTree one
3 -> deepA two emptyTree one
4 -> deepA two emptyTree two
5 -> deepA three emptyTree two
6 -> deepA three emptyTree three
_ -> case n `quotRem` 3 of
(q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three
(q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two
(q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two
where !mSize' = 3 * mSize
n3 = liftA3 (Node3 mSize') m m m
where
one = fmap One m
two = liftA2 Two m m
three = liftA3 Three m m m
deepA = liftA3 (Deep (n * mSize))
emptyTree = pure EmptyT
empty :: Seq a
empty = Seq EmptyT
singleton :: a -> Seq a
singleton x = Seq (Single (Elem x))
replicate :: Int -> a -> Seq a
replicate n x
| n >= 0 = runIdentity (replicateA n (Identity x))
| otherwise = error "replicate takes a nonnegative integer argument"
replicateA :: Applicative f => Int -> f a -> f (Seq a)
replicateA n x
| n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)
| otherwise = error "replicateA takes a nonnegative integer argument"
{-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-}
#if MIN_VERSION_base(4,8,0)
replicateM :: Applicative m => Int -> m a -> m (Seq a)
replicateM = replicateA
#else
replicateM :: Monad m => Int -> m a -> m (Seq a)
replicateM n x
| n >= 0 = Applicative.unwrapMonad (replicateA n (Applicative.WrapMonad x))
| otherwise = error "replicateM takes a nonnegative integer argument"
#endif
cycleTaking :: Int -> Seq a -> Seq a
cycleTaking n !_xs | n <= 0 = empty
cycleTaking _n xs | null xs = error "cycleTaking cannot take a positive number of elements from an empty cycle."
cycleTaking n xs = cycleNTimes reps xs >< take final xs
where
(reps, final) = n `quotRem` length xs
cycleNTimes :: Int -> Seq a -> Seq a
cycleNTimes n !xs
| n <= 0 = empty
| n == 1 = xs
cycleNTimes n (Seq xsFT) = case rigidify xsFT of
RigidEmpty -> empty
RigidOne (Elem x) -> replicate n x
RigidTwo x1 x2 -> Seq $
Deep (n*2) pair
(runIdentity $ applicativeTree (n-2) 2 (Identity (node2 x1 x2)))
pair
where pair = Two x1 x2
RigidThree x1 x2 x3 -> Seq $
Deep (n*3) triple
(runIdentity $ applicativeTree (n-2) 3 (Identity (node3 x1 x2 x3)))
triple
where triple = Three x1 x2 x3
RigidFull r@(Rigid s pr _m sf) -> Seq $
Deep (n*s)
(nodeToDigit pr)
(cycleNMiddle (n-2) r)
(nodeToDigit sf)
cycleNMiddle
:: Int
-> Rigid c
-> FingerTree (Node c)
cycleNMiddle !n
(Rigid s pr (DeepTh sm prm mm sfm) sf)
= Deep (sm + s * (n + 1))
(digit12ToDigit prm)
(cycleNMiddle n
(Rigid s (squashL pr prm) mm (squashR sfm sf)))
(digit12ToDigit sfm)
cycleNMiddle n
(Rigid s pr EmptyTh sf)
= deep
(One sf)
(runIdentity $ applicativeTree n s (Identity converted))
(One pr)
where converted = node2 pr sf
cycleNMiddle n
(Rigid s pr (SingleTh q) sf)
= deep
(Two q sf)
(runIdentity $ applicativeTree n s (Identity converted))
(Two pr q)
where converted = node3 pr q sf
(<|) :: a -> Seq a -> Seq a
x <| Seq xs = Seq (Elem x `consTree` xs)
{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
consTree :: Sized a => a -> FingerTree a -> FingerTree a
consTree a EmptyT = Single a
consTree a (Single b) = deep (One a) EmptyT (One b)
consTree a (Deep s (Four b c d e) m sf) = m `seq`
Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
consTree a (Deep s (Three b c d) m sf) =
Deep (size a + s) (Four a b c d) m sf
consTree a (Deep s (Two b c) m sf) =
Deep (size a + s) (Three a b c) m sf
consTree a (Deep s (One b) m sf) =
Deep (size a + s) (Two a b) m sf
cons' :: a -> Seq a -> Seq a
cons' x (Seq xs) = Seq (Elem x `consTree'` xs)
snoc' :: Seq a -> a -> Seq a
snoc' (Seq xs) x = Seq (xs `snocTree'` Elem x)
{-# SPECIALIZE consTree' :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE consTree' :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
consTree' :: Sized a => a -> FingerTree a -> FingerTree a
consTree' a EmptyT = Single a
consTree' a (Single b) = deep (One a) EmptyT (One b)
consTree' a (Deep s (Four b c d e) m sf) =
Deep (size a + s) (Two a b) m' sf
where !m' = abc `consTree'` m
!abc = node3 c d e
consTree' a (Deep s (Three b c d) m sf) =
Deep (size a + s) (Four a b c d) m sf
consTree' a (Deep s (Two b c) m sf) =
Deep (size a + s) (Three a b c) m sf
consTree' a (Deep s (One b) m sf) =
Deep (size a + s) (Two a b) m sf
(|>) :: Seq a -> a -> Seq a
Seq xs |> x = Seq (xs `snocTree` Elem x)
{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
snocTree :: Sized a => FingerTree a -> a -> FingerTree a
snocTree EmptyT a = Single a
snocTree (Single a) b = deep (One a) EmptyT (One b)
snocTree (Deep s pr m (Four a b c d)) e = m `seq`
Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
snocTree (Deep s pr m (Three a b c)) d =
Deep (s + size d) pr m (Four a b c d)
snocTree (Deep s pr m (Two a b)) c =
Deep (s + size c) pr m (Three a b c)
snocTree (Deep s pr m (One a)) b =
Deep (s + size b) pr m (Two a b)
{-# SPECIALIZE snocTree' :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
{-# SPECIALIZE snocTree' :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
snocTree' :: Sized a => FingerTree a -> a -> FingerTree a
snocTree' EmptyT a = Single a
snocTree' (Single a) b = deep (One a) EmptyT (One b)
snocTree' (Deep s pr m (Four a b c d)) e =
Deep (s + size e) pr m' (Two d e)
where !m' = m `snocTree'` abc
!abc = node3 a b c
snocTree' (Deep s pr m (Three a b c)) d =
Deep (s + size d) pr m (Four a b c d)
snocTree' (Deep s pr m (Two a b)) c =
Deep (s + size c) pr m (Three a b c)
snocTree' (Deep s pr m (One a)) b =
Deep (s + size b) pr m (Two a b)
(><) :: Seq a -> Seq a -> Seq a
Seq xs >< Seq ys = Seq (appendTree0 xs ys)
appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
appendTree0 EmptyT xs =
xs
appendTree0 xs EmptyT =
xs
appendTree0 (Single x) xs =
x `consTree` xs
appendTree0 xs (Single x) =
xs `snocTree` x
appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
Deep (s1 + s2) pr1 m sf2
where !m = addDigits0 m1 sf1 pr2 m2
addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
addDigits0 m1 (One a) (One b) m2 =
appendTree1 m1 (node2 a b) m2
addDigits0 m1 (One a) (Two b c) m2 =
appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (One a) (Three b c d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (One a) (Four b c d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (One c) m2 =
appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (Two a b) (Two c d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Two a b) (Three c d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (Four c d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (One d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Three a b c) (Two d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Three a b c) (Three d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (Four d e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Four a b c d) (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Four a b c d) (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree1 EmptyT !a xs =
a `consTree` xs
appendTree1 xs !a EmptyT =
xs `snocTree` a
appendTree1 (Single x) !a xs =
x `consTree` a `consTree` xs
appendTree1 xs !a (Single x) =
xs `snocTree` a `snocTree` x
appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + s2) pr1 m sf2
where !m = addDigits1 m1 sf1 a pr2 m2
addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits1 m1 (One a) b (One c) m2 =
appendTree1 m1 (node3 a b c) m2
addDigits1 m1 (One a) b (Two c d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (One a) b (Three c d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (One a) b (Four c d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (One d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (Two a b) c (Two d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Two a b) c (Three d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (Four d e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Three a b c) d (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Three a b c) d (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Four a b c d) e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree2 EmptyT !a !b xs =
a `consTree` b `consTree` xs
appendTree2 xs !a !b EmptyT =
xs `snocTree` a `snocTree` b
appendTree2 (Single x) a b xs =
x `consTree` a `consTree` b `consTree` xs
appendTree2 xs a b (Single x) =
xs `snocTree` a `snocTree` b `snocTree` x
appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + size b + s2) pr1 m sf2
where !m = addDigits2 m1 sf1 a b pr2 m2
addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits2 m1 (One a) b c (One d) m2 =
appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits2 m1 (One a) b c (Two d e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (One a) b c (Three d e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (One a) b c (Four d e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (Two a b) c d (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Two a b) c d (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Three a b c) d e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (One g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree3 EmptyT !a !b !c xs =
a `consTree` b `consTree` c `consTree` xs
appendTree3 xs !a !b !c EmptyT =
xs `snocTree` a `snocTree` b `snocTree` c
appendTree3 (Single x) a b c xs =
x `consTree` a `consTree` b `consTree` c `consTree` xs
appendTree3 xs a b c (Single x) =
xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + size b + size c + s2) pr1 m sf2
where !m = addDigits3 m1 sf1 a b c pr2 m2
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))
addDigits3 m1 (One a) !b !c !d (One e) m2 =
appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits3 m1 (One a) b c d (Two e f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (One a) b c d (Three e f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (One a) b c d (Four e f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) !c !d !e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (Two a b) c d e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) !d !e !f (One g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) !e !f !g (One h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree4 EmptyT !a !b !c !d xs =
a `consTree` b `consTree` c `consTree` d `consTree` xs
appendTree4 xs !a !b !c !d EmptyT =
xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d
appendTree4 (Single x) a b c d xs =
x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs
appendTree4 xs a b c d (Single x) =
xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x
appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =
Deep (s1 + size a + size b + size c + size d + s2) pr1 m sf2
where !m = addDigits4 m1 sf1 a b c d pr2 m2
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))
addDigits4 m1 (One a) !b !c !d !e (One f) m2 =
appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits4 m1 (One a) b c d e (Two f g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits4 m1 (One a) b c d e (Three f g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Two a b) !c !d !e !f (One g) m2 =
appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Three a b c) !d !e !f !g (One h) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
addDigits4 m1 (Four a b c d) !e !f !g !h (One i) m2 =
appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Four a b c d) !e !f !g !h (Two i j) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Four a b c d) !e !f !g !h (Three i j k) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
addDigits4 m1 (Four a b c d) !e !f !g !h (Four i j k l) m2 =
appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2
unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a
unfoldr f = unfoldr' empty
where unfoldr' !as b = maybe as (\ (a, b') -> unfoldr' (as `snoc'` a) b') (f b)
unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a
unfoldl f = unfoldl' empty
where unfoldl' !as b = maybe as (\ (b', a) -> unfoldl' (a `cons'` as) b') (f b)
iterateN :: Int -> (a -> a) -> a -> Seq a
iterateN n f x
| n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x
| otherwise = error "iterateN takes a nonnegative integer argument"
null :: Seq a -> Bool
null (Seq EmptyT) = True
null _ = False
length :: Seq a -> Int
length (Seq xs) = size xs
data ViewLTree a = ConsLTree a (FingerTree a) | EmptyLTree
data ViewRTree a = SnocRTree (FingerTree a) a | EmptyRTree
data ViewL a
= EmptyL
| a :< Seq a
deriving (Eq, Ord, Show, Read)
#if __GLASGOW_HASKELL__
deriving instance Data a => Data (ViewL a)
#endif
#if __GLASGOW_HASKELL__ >= 706
deriving instance Generic1 ViewL
#endif
#if __GLASGOW_HASKELL__ >= 702
deriving instance Generic (ViewL a)
#endif
INSTANCE_TYPEABLE1(ViewL)
instance Functor ViewL where
{-# INLINE fmap #-}
fmap _ EmptyL = EmptyL
fmap f (x :< xs) = f x :< fmap f xs
instance Foldable ViewL where
foldr _ z EmptyL = z
foldr f z (x :< xs) = f x (foldr f z xs)
foldl _ z EmptyL = z
foldl f z (x :< xs) = foldl f (f z x) xs
foldl1 _ EmptyL = error "foldl1: empty view"
foldl1 f (x :< xs) = foldl f x xs
#if MIN_VERSION_base(4,8,0)
null EmptyL = True
null (_ :< _) = False
length EmptyL = 0
length (_ :< xs) = 1 + length xs
#endif
instance Traversable ViewL where
traverse _ EmptyL = pure EmptyL
traverse f (x :< xs) = liftA2 (:<) (f x) (traverse f xs)
viewl :: Seq a -> ViewL a
viewl (Seq xs) = case viewLTree xs of
EmptyLTree -> EmptyL
ConsLTree (Elem x) xs' -> x :< Seq xs'
{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> ViewLTree (Elem a) #-}
{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> ViewLTree (Node a) #-}
viewLTree :: Sized a => FingerTree a -> ViewLTree a
viewLTree EmptyT = EmptyLTree
viewLTree (Single a) = ConsLTree a EmptyT
viewLTree (Deep s (One a) m sf) = ConsLTree a (pullL (s - size a) m sf)
viewLTree (Deep s (Two a b) m sf) =
ConsLTree a (Deep (s - size a) (One b) m sf)
viewLTree (Deep s (Three a b c) m sf) =
ConsLTree a (Deep (s - size a) (Two b c) m sf)
viewLTree (Deep s (Four a b c d) m sf) =
ConsLTree a (Deep (s - size a) (Three b c d) m sf)
data ViewR a
= EmptyR
| Seq a :> a
deriving (Eq, Ord, Show, Read)
#if __GLASGOW_HASKELL__
deriving instance Data a => Data (ViewR a)
#endif
#if __GLASGOW_HASKELL__ >= 706
deriving instance Generic1 ViewR
#endif
#if __GLASGOW_HASKELL__ >= 702
deriving instance Generic (ViewR a)
#endif
INSTANCE_TYPEABLE1(ViewR)
instance Functor ViewR where
{-# INLINE fmap #-}
fmap _ EmptyR = EmptyR
fmap f (xs :> x) = fmap f xs :> f x
instance Foldable ViewR where
foldMap _ EmptyR = mempty
foldMap f (xs :> x) = foldMap f xs <> f x
foldr _ z EmptyR = z
foldr f z (xs :> x) = foldr f (f x z) xs
foldl _ z EmptyR = z
foldl f z (xs :> x) = foldl f z xs `f` x
foldr1 _ EmptyR = error "foldr1: empty view"
foldr1 f (xs :> x) = foldr f x xs
#if MIN_VERSION_base(4,8,0)
null EmptyR = True
null (_ :> _) = False
length EmptyR = 0
length (xs :> _) = length xs + 1
#endif
instance Traversable ViewR where
traverse _ EmptyR = pure EmptyR
traverse f (xs :> x) = liftA2 (:>) (traverse f xs) (f x)
viewr :: Seq a -> ViewR a
viewr (Seq xs) = case viewRTree xs of
EmptyRTree -> EmptyR
SnocRTree xs' (Elem x) -> Seq xs' :> x
{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> ViewRTree (Elem a) #-}
{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> ViewRTree (Node a) #-}
viewRTree :: Sized a => FingerTree a -> ViewRTree a
viewRTree EmptyT = EmptyRTree
viewRTree (Single z) = SnocRTree EmptyT z
viewRTree (Deep s pr m (One z)) = SnocRTree (pullR (s - size z) pr m) z
viewRTree (Deep s pr m (Two y z)) =
SnocRTree (Deep (s - size z) pr m (One y)) z
viewRTree (Deep s pr m (Three x y z)) =
SnocRTree (Deep (s - size z) pr m (Two x y)) z
viewRTree (Deep s pr m (Four w x y z)) =
SnocRTree (Deep (s - size z) pr m (Three w x y)) z
scanl :: (a -> b -> a) -> a -> Seq b -> Seq a
scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)
scanl1 :: (a -> a -> a) -> Seq a -> Seq a
scanl1 f xs = case viewl xs of
EmptyL -> error "scanl1 takes a nonempty sequence as an argument"
x :< xs' -> scanl f x xs'
scanr :: (a -> b -> b) -> b -> Seq a -> Seq b
scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0
scanr1 :: (a -> a -> a) -> Seq a -> Seq a
scanr1 f xs = case viewr xs of
EmptyR -> error "scanr1 takes a nonempty sequence as an argument"
xs' :> x -> scanr f x xs'
index :: Seq a -> Int -> a
index (Seq xs) i
| fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of
Place _ (Elem x) -> x
| otherwise =
error $ "index out of bounds in call to: Data.Sequence.index " ++ show i
lookup :: Int -> Seq a -> Maybe a
lookup i (Seq xs)
| fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of
Place _ (Elem x) -> Just x
| otherwise = Nothing
(!?) :: Seq a -> Int -> Maybe a
(!?) = flip lookup
data Place a = Place {-# UNPACK #-} !Int a
#ifdef TESTING
deriving Show
#endif
{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}
{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}
lookupTree :: Sized a => Int -> FingerTree a -> Place a
lookupTree !_ EmptyT = error "lookupTree of empty tree"
lookupTree i (Single x) = Place i x
lookupTree i (Deep _ pr m sf)
| i < spr = lookupDigit i pr
| i < spm = case lookupTree (i - spr) m of
Place i' xs -> lookupNode i' xs
| otherwise = lookupDigit (i - spm) sf
where
spr = size pr
spm = spr + size m
{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}
{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}
lookupNode :: Sized a => Int -> Node a -> Place a
lookupNode i (Node2 _ a b)
| i < sa = Place i a
| otherwise = Place (i - sa) b
where
sa = size a
lookupNode i (Node3 _ a b c)
| i < sa = Place i a
| i < sab = Place (i - sa) b
| otherwise = Place (i - sab) c
where
sa = size a
sab = sa + size b
{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}
{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}
lookupDigit :: Sized a => Int -> Digit a -> Place a
lookupDigit i (One a) = Place i a
lookupDigit i (Two a b)
| i < sa = Place i a
| otherwise = Place (i - sa) b
where
sa = size a
lookupDigit i (Three a b c)
| i < sa = Place i a
| i < sab = Place (i - sa) b
| otherwise = Place (i - sab) c
where
sa = size a
sab = sa + size b
lookupDigit i (Four a b c d)
| i < sa = Place i a
| i < sab = Place (i - sa) b
| i < sabc = Place (i - sab) c
| otherwise = Place (i - sabc) d
where
sa = size a
sab = sa + size b
sabc = sab + size c
update :: Int -> a -> Seq a -> Seq a
update i x (Seq xs)
| fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (updateTree (Elem x) i xs)
| otherwise = Seq xs
updateTree :: Elem a -> Int -> FingerTree (Elem a) -> FingerTree (Elem a)
updateTree _ !_ EmptyT = EmptyT
updateTree v _i (Single _) = Single v
updateTree v i (Deep s pr m sf)
| i < spr = Deep s (updateDigit v i pr) m sf
| i < spm = let !m' = adjustTree (updateNode v) (i - spr) m
in Deep s pr m' sf
| otherwise = Deep s pr m (updateDigit v (i - spm) sf)
where
spr = size pr
spm = spr + size m
updateNode :: Elem a -> Int -> Node (Elem a) -> Node (Elem a)
updateNode v i (Node2 s a b)
| i < sa = Node2 s v b
| otherwise = Node2 s a v
where
sa = size a
updateNode v i (Node3 s a b c)
| i < sa = Node3 s v b c
| i < sab = Node3 s a v c
| otherwise = Node3 s a b v
where
sa = size a
sab = sa + size b
updateDigit :: Elem a -> Int -> Digit (Elem a) -> Digit (Elem a)
updateDigit v !_i (One _) = One v
updateDigit v i (Two a b)
| i < sa = Two v b
| otherwise = Two a v
where
sa = size a
updateDigit v i (Three a b c)
| i < sa = Three v b c
| i < sab = Three a v c
| otherwise = Three a b v
where
sa = size a
sab = sa + size b
updateDigit v i (Four a b c d)
| i < sa = Four v b c d
| i < sab = Four a v c d
| i < sabc = Four a b v d
| otherwise = Four a b c v
where
sa = size a
sab = sa + size b
sabc = sab + size c
adjust :: (a -> a) -> Int -> Seq a -> Seq a
adjust f i (Seq xs)
| fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (adjustTree (`seq` fmap f) i xs)
| otherwise = Seq xs
adjust' :: forall a . (a -> a) -> Int -> Seq a -> Seq a
#if __GLASGOW_HASKELL__ >= 708
adjust' f i xs
| fromIntegral i < (fromIntegral (length xs) :: Word) =
coerce $ adjustTree (\ !_k (ForceBox a) -> ForceBox (f a)) i (coerce xs)
| otherwise = xs
#else
adjust' f i xs =
case xs !? i of
Nothing -> xs
Just x -> let !x' = f x
in update i x' xs
#endif
{-# SPECIALIZE adjustTree :: (Int -> ForceBox a -> ForceBox a) -> Int -> FingerTree (ForceBox a) -> FingerTree (ForceBox a) #-}
{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
adjustTree :: (Sized a, MaybeForce a) => (Int -> a -> a) ->
Int -> FingerTree a -> FingerTree a
adjustTree _ !_ EmptyT = EmptyT
adjustTree f i (Single x) = Single $!? f i x
adjustTree f i (Deep s pr m sf)
| i < spr = Deep s (adjustDigit f i pr) m sf
| i < spm = let !m' = adjustTree (adjustNode f) (i - spr) m
in Deep s pr m' sf
| otherwise = Deep s pr m (adjustDigit f (i - spm) sf)
where
spr = size pr
spm = spr + size m
{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}
{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}
adjustNode :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Node a -> Node a
adjustNode f i (Node2 s a b)
| i < sa = let fia = f i a in fia `mseq` Node2 s fia b
| otherwise = let fisab = f (i - sa) b in fisab `mseq` Node2 s a fisab
where
sa = size a
adjustNode f i (Node3 s a b c)
| i < sa = let fia = f i a in fia `mseq` Node3 s fia b c
| i < sab = let fisab = f (i - sa) b in fisab `mseq` Node3 s a fisab c
| otherwise = let fisabc = f (i - sab) c in fisabc `mseq` Node3 s a b fisabc
where
sa = size a
sab = sa + size b
{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}
{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}
adjustDigit :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Digit a -> Digit a
adjustDigit f !i (One a) = One $!? f i a
adjustDigit f i (Two a b)
| i < sa = let fia = f i a in fia `mseq` Two fia b
| otherwise = let fisab = f (i - sa) b in fisab `mseq` Two a fisab
where
sa = size a
adjustDigit f i (Three a b c)
| i < sa = let fia = f i a in fia `mseq` Three fia b c
| i < sab = let fisab = f (i - sa) b in fisab `mseq` Three a fisab c
| otherwise = let fisabc = f (i - sab) c in fisabc `mseq` Three a b fisabc
where
sa = size a
sab = sa + size b
adjustDigit f i (Four a b c d)
| i < sa = let fia = f i a in fia `mseq` Four fia b c d
| i < sab = let fisab = f (i - sa) b in fisab `mseq` Four a fisab c d
| i < sabc = let fisabc = f (i - sab) c in fisabc `mseq` Four a b fisabc d
| otherwise = let fisabcd = f (i - sabc) d in fisabcd `mseq` Four a b c fisabcd
where
sa = size a
sab = sa + size b
sabc = sab + size c
insertAt :: Int -> a -> Seq a -> Seq a
insertAt i a s@(Seq xs)
| fromIntegral i < (fromIntegral (size xs) :: Word)
= Seq (insTree (`seq` InsTwo (Elem a)) i xs)
| i <= 0 = a <| s
| otherwise = s |> a
data Ins a = InsOne a | InsTwo a a
{-# SPECIALIZE insTree :: (Int -> Elem a -> Ins (Elem a)) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE insTree :: (Int -> Node a -> Ins (Node a)) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}
insTree :: Sized a => (Int -> a -> Ins a) ->
Int -> FingerTree a -> FingerTree a
insTree _ !_ EmptyT = EmptyT
insTree f i (Single x) = case f i x of
InsOne x' -> Single x'
InsTwo m n -> deep (One m) EmptyT (One n)
insTree f i (Deep s pr m sf)
| i < spr = case insLeftDigit f i pr of
InsLeftDig pr' -> Deep (s + 1) pr' m sf
InsDigNode pr' n -> m `seq` Deep (s + 1) pr' (n `consTree` m) sf
| i < spm = let !m' = insTree (insNode f) (i - spr) m
in Deep (s + 1) pr m' sf
| otherwise = case insRightDigit f (i - spm) sf of
InsRightDig sf' -> Deep (s + 1) pr m sf'
InsNodeDig n sf' -> m `seq` Deep (s + 1) pr (m `snocTree` n) sf'
where
spr = size pr
spm = spr + size m
{-# SPECIALIZE insNode :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Node (Elem a) -> Ins (Node (Elem a)) #-}
{-# SPECIALIZE insNode :: (Int -> Node a -> Ins (Node a)) -> Int -> Node (Node a) -> Ins (Node (Node a)) #-}
insNode :: Sized a => (Int -> a -> Ins a) -> Int -> Node a -> Ins (Node a)
insNode f i (Node2 s a b)
| i < sa = case f i a of
InsOne n -> InsOne $ Node2 (s + 1) n b
InsTwo m n -> InsOne $ Node3 (s + 1) m n b
| otherwise = case f (i - sa) b of
InsOne n -> InsOne $ Node2 (s + 1) a n
InsTwo m n -> InsOne $ Node3 (s + 1) a m n
where sa = size a
insNode f i (Node3 s a b c)
| i < sa = case f i a of
InsOne n -> InsOne $ Node3 (s + 1) n b c
InsTwo m n -> InsTwo (Node2 (sa + 1) m n) (Node2 (s - sa) b c)
| i < sab = case f (i - sa) b of
InsOne n -> InsOne $ Node3 (s + 1) a n c
InsTwo m n -> InsTwo am nc
where !am = node2 a m
!nc = node2 n c
| otherwise = case f (i - sab) c of
InsOne n -> InsOne $ Node3 (s + 1) a b n
InsTwo m n -> InsTwo (Node2 sab a b) (Node2 (s - sab + 1) m n)
where sa = size a
sab = sa + size b
data InsDigNode a = InsLeftDig !(Digit a) | InsDigNode !(Digit a) !(Node a)
{-# SPECIALIZE insLeftDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsDigNode (Elem a) #-}
{-# SPECIALIZE insLeftDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsDigNode (Node a) #-}
insLeftDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsDigNode a
insLeftDigit f !i (One a) = case f i a of
InsOne a' -> InsLeftDig $ One a'
InsTwo a1 a2 -> InsLeftDig $ Two a1 a2
insLeftDigit f i (Two a b)
| i < sa = case f i a of
InsOne a' -> InsLeftDig $ Two a' b
InsTwo a1 a2 -> InsLeftDig $ Three a1 a2 b
| otherwise = case f (i - sa) b of
InsOne b' -> InsLeftDig $ Two a b'
InsTwo b1 b2 -> InsLeftDig $ Three a b1 b2
where sa = size a
insLeftDigit f i (Three a b c)
| i < sa = case f i a of
InsOne a' -> InsLeftDig $ Three a' b c
InsTwo a1 a2 -> InsLeftDig $ Four a1 a2 b c
| i < sab = case f (i - sa) b of
InsOne b' -> InsLeftDig $ Three a b' c
InsTwo b1 b2 -> InsLeftDig $ Four a b1 b2 c
| otherwise = case f (i - sab) c of
InsOne c' -> InsLeftDig $ Three a b c'
InsTwo c1 c2 -> InsLeftDig $ Four a b c1 c2
where sa = size a
sab = sa + size b
insLeftDigit f i (Four a b c d)
| i < sa = case f i a of
InsOne a' -> InsLeftDig $ Four a' b c d
InsTwo a1 a2 -> InsDigNode (Two a1 a2) (node3 b c d)
| i < sab = case f (i - sa) b of
InsOne b' -> InsLeftDig $ Four a b' c d
InsTwo b1 b2 -> InsDigNode (Two a b1) (node3 b2 c d)
| i < sabc = case f (i - sab) c of
InsOne c' -> InsLeftDig $ Four a b c' d
InsTwo c1 c2 -> InsDigNode (Two a b) (node3 c1 c2 d)
| otherwise = case f (i - sabc) d of
InsOne d' -> InsLeftDig $ Four a b c d'
InsTwo d1 d2 -> InsDigNode (Two a b) (node3 c d1 d2)
where sa = size a
sab = sa + size b
sabc = sab + size c
data InsNodeDig a = InsRightDig !(Digit a) | InsNodeDig !(Node a) !(Digit a)
{-# SPECIALIZE insRightDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsNodeDig (Elem a) #-}
{-# SPECIALIZE insRightDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsNodeDig (Node a) #-}
insRightDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsNodeDig a
insRightDigit f !i (One a) = case f i a of
InsOne a' -> InsRightDig $ One a'
InsTwo a1 a2 -> InsRightDig $ Two a1 a2
insRightDigit f i (Two a b)
| i < sa = case f i a of
InsOne a' -> InsRightDig $ Two a' b
InsTwo a1 a2 -> InsRightDig $ Three a1 a2 b
| otherwise = case f (i - sa) b of
InsOne b' -> InsRightDig $ Two a b'
InsTwo b1 b2 -> InsRightDig $ Three a b1 b2
where sa = size a
insRightDigit f i (Three a b c)
| i < sa = case f i a of
InsOne a' -> InsRightDig $ Three a' b c
InsTwo a1 a2 -> InsRightDig $ Four a1 a2 b c
| i < sab = case f (i - sa) b of
InsOne b' -> InsRightDig $ Three a b' c
InsTwo b1 b2 -> InsRightDig $ Four a b1 b2 c
| otherwise = case f (i - sab) c of
InsOne c' -> InsRightDig $ Three a b c'
InsTwo c1 c2 -> InsRightDig $ Four a b c1 c2
where sa = size a
sab = sa + size b
insRightDigit f i (Four a b c d)
| i < sa = case f i a of
InsOne a' -> InsRightDig $ Four a' b c d
InsTwo a1 a2 -> InsNodeDig (node3 a1 a2 b) (Two c d)
| i < sab = case f (i - sa) b of
InsOne b' -> InsRightDig $ Four a b' c d
InsTwo b1 b2 -> InsNodeDig (node3 a b1 b2) (Two c d)
| i < sabc = case f (i - sab) c of
InsOne c' -> InsRightDig $ Four a b c' d
InsTwo c1 c2 -> InsNodeDig (node3 a b c1) (Two c2 d)
| otherwise = case f (i - sabc) d of
InsOne d' -> InsRightDig $ Four a b c d'
InsTwo d1 d2 -> InsNodeDig (node3 a b c) (Two d1 d2)
where sa = size a
sab = sa + size b
sabc = sab + size c
deleteAt :: Int -> Seq a -> Seq a
deleteAt i (Seq xs)
| fromIntegral i < (fromIntegral (size xs) :: Word) = Seq $ delTreeE i xs
| otherwise = Seq xs
delTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)
delTreeE !_i EmptyT = EmptyT
delTreeE _i Single{} = EmptyT
delTreeE i (Deep s pr m sf)
| i < spr = delLeftDigitE i s pr m sf
| i < spm = case delTree delNodeE (i - spr) m of
FullTree m' -> Deep (s - 1) pr m' sf
DefectTree e -> delRebuildMiddle (s - 1) pr e sf
| otherwise = delRightDigitE (i - spm) s pr m sf
where spr = size pr
spm = spr + size m
delNodeE :: Int -> Node (Elem a) -> Del (Elem a)
delNodeE i (Node3 _ a b c) = case i of
0 -> Full $ Node2 2 b c
1 -> Full $ Node2 2 a c
_ -> Full $ Node2 2 a b
delNodeE i (Node2 _ a b) = case i of
0 -> Defect b
_ -> Defect a
delLeftDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)
delLeftDigitE !_i s One{} m sf = pullL (s - 1) m sf
delLeftDigitE i s (Two a b) m sf
| i == 0 = Deep (s - 1) (One b) m sf
| otherwise = Deep (s - 1) (One a) m sf
delLeftDigitE i s (Three a b c) m sf
| i == 0 = Deep (s - 1) (Two b c) m sf
| i == 1 = Deep (s - 1) (Two a c) m sf
| otherwise = Deep (s - 1) (Two a b) m sf
delLeftDigitE i s (Four a b c d) m sf
| i == 0 = Deep (s - 1) (Three b c d) m sf
| i == 1 = Deep (s - 1) (Three a c d) m sf
| i == 2 = Deep (s - 1) (Three a b d) m sf
| otherwise = Deep (s - 1) (Three a b c) m sf
delRightDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)
delRightDigitE !_i s pr m One{} = pullR (s - 1) pr m
delRightDigitE i s pr m (Two a b)
| i == 0 = Deep (s - 1) pr m (One b)
| otherwise = Deep (s - 1) pr m (One a)
delRightDigitE i s pr m (Three a b c)
| i == 0 = Deep (s - 1) pr m (Two b c)
| i == 1 = Deep (s - 1) pr m (Two a c)
| otherwise = deep pr m (Two a b)
delRightDigitE i s pr m (Four a b c d)
| i == 0 = Deep (s - 1) pr m (Three b c d)
| i == 1 = Deep (s - 1) pr m (Three a c d)
| i == 2 = Deep (s - 1) pr m (Three a b d)
| otherwise = Deep (s - 1) pr m (Three a b c)
data DelTree a = FullTree !(FingerTree (Node a)) | DefectTree a
{-# SPECIALIZE delTree :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> FingerTree (Node (Elem a)) -> DelTree (Elem a) #-}
{-# SPECIALIZE delTree :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> FingerTree (Node (Node a)) -> DelTree (Node a) #-}
delTree :: Sized a => (Int -> Node a -> Del a) -> Int -> FingerTree (Node a) -> DelTree a
delTree _f !_i EmptyT = FullTree EmptyT
delTree f i (Single a) = case f i a of
Full a' -> FullTree (Single a')
Defect e -> DefectTree e
delTree f i (Deep s pr m sf)
| i < spr = case delDigit f i pr of
FullDig pr' -> FullTree $ Deep (s - 1) pr' m sf
DefectDig e -> case viewLTree m of
EmptyLTree -> FullTree $ delRebuildRightDigit (s - 1) e sf
ConsLTree n m' -> FullTree $ delRebuildLeftSide (s - 1) e n m' sf
| i < spm = case delTree (delNode f) (i - spr) m of
FullTree m' -> FullTree (Deep (s - 1) pr m' sf)
DefectTree e -> FullTree $ delRebuildMiddle (s - 1) pr e sf
| otherwise = case delDigit f (i - spm) sf of
FullDig sf' -> FullTree $ Deep (s - 1) pr m sf'
DefectDig e -> case viewRTree m of
EmptyRTree -> FullTree $ delRebuildLeftDigit (s - 1) pr e
SnocRTree m' n -> FullTree $ delRebuildRightSide (s - 1) pr m' n e
where spr = size pr
spm = spr + size m
data Del a = Full !(Node a) | Defect a
{-# SPECIALIZE delNode :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Node (Node (Elem a)) -> Del (Node (Elem a)) #-}
{-# SPECIALIZE delNode :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Node (Node (Node a)) -> Del (Node (Node a)) #-}
delNode :: Sized a => (Int -> Node a -> Del a) -> Int -> Node (Node a) -> Del (Node a)
delNode f i (Node3 s a b c)
| i < sa = case f i a of
Full a' -> Full $ Node3 (s - 1) a' b c
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c
where !sx = size x
Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) e x y) c
| i < sab = case f (i - sa) b of
Full b' -> Full $ Node3 (s - 1) a b' c
Defect e -> let !se = size e in case a of
Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c
where !sz = size z
Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) x y e) c
| otherwise = case f (i - sab) c of
Full c' -> Full $ Node3 (s - 1) a b c'
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> Full $ Node3 (s - 1) a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
where !sz = size z
Node2 sxy x y -> Full $ Node2 (s - 1) a (Node3 (sxy + se) x y e)
where sa = size a
sab = sa + size b
delNode f i (Node2 s a b)
| i < sa = case f i a of
Full a' -> Full $ Node2 (s - 1) a' b
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)
where !sx = size x
Node2 _ x y -> Defect $ Node3 (s - 1) e x y
| otherwise = case f (i - sa) b of
Full b' -> Full $ Node2 (s - 1) a b'
Defect e -> let !se = size e in case a of
Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
where !sz = size z
Node2 _ x y -> Defect $ Node3 (s - 1) x y e
where sa = size a
{-# SPECIALIZE delRebuildRightDigit :: Int -> Elem a -> Digit (Node (Elem a)) -> FingerTree (Node (Elem a)) #-}
{-# SPECIALIZE delRebuildRightDigit :: Int -> Node a -> Digit (Node (Node a)) -> FingerTree (Node (Node a)) #-}
delRebuildRightDigit :: Sized a => Int -> a -> Digit (Node a) -> FingerTree (Node a)
delRebuildRightDigit s p (One a) = let !sp = size p in case a of
Node3 sxyz x y z -> Deep s (One (Node2 (sp + sx) p x)) EmptyT (One (Node2 (sxyz - sx) y z))
where !sx = size x
Node2 sxy x y -> Single (Node3 (sp + sxy) p x y)
delRebuildRightDigit s p (Two a b) = let !sp = size p in case a of
Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (One b)
where !sx = size x
Node2 sxy x y -> Deep s (One (Node3 (sp + sxy) p x y)) EmptyT (One b)
delRebuildRightDigit s p (Three a b c) = let !sp = size p in case a of
Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (Two b c)
where !sx = size x
Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (One c)
delRebuildRightDigit s p (Four a b c d) = let !sp = size p in case a of
Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) EmptyT (Two c d)
where !sx = size x
Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (Two c d)
{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Elem a)) -> Elem a -> FingerTree (Node (Elem a)) #-}
{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Node a)) -> Node a -> FingerTree (Node (Node a)) #-}
delRebuildLeftDigit :: Sized a => Int -> Digit (Node a) -> a -> FingerTree (Node a)
delRebuildLeftDigit s (One a) p = let !sp = size p in case a of
Node3 sxyz x y z -> Deep s (One (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))
where !sz = size z
Node2 sxy x y -> Single (Node3 (sxy + sp) x y p)
delRebuildLeftDigit s (Two a b) p = let !sp = size p in case b of
Node3 sxyz x y z -> Deep s (Two a (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))
where !sz = size z
Node2 sxy x y -> Deep s (One a) EmptyT (One (Node3 (sxy + sp) x y p))
delRebuildLeftDigit s (Three a b c) p = let !sp = size p in case c of
Node3 sxyz x y z -> Deep s (Two a b) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
where !sz = size z
Node2 sxy x y -> Deep s (Two a b) EmptyT (One (Node3 (sxy + sp) x y p))
delRebuildLeftDigit s (Four a b c d) p = let !sp = size p in case d of
Node3 sxyz x y z -> Deep s (Three a b c) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
where !sz = size z
Node2 sxy x y -> Deep s (Two a b) EmptyT (Two c (Node3 (sxy + sp) x y p))
delRebuildLeftSide :: Sized a
=> Int -> a -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)
-> FingerTree (Node a)
delRebuildLeftSide s p (Node2 _ a b) m sf = let !sp = size p in case a of
Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) m sf
Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) m sf
where !sx = size x
delRebuildLeftSide s p (Node3 _ a b c) m sf = let !sp = size p in case a of
Node2 sxy x y -> Deep s (Three (Node3 (sp + sxy) p x y) b c) m sf
Node3 sxyz x y z -> Deep s (Four (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b c) m sf
where !sx = size x
delRebuildRightSide :: Sized a
=> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> a
-> FingerTree (Node a)
delRebuildRightSide s pr m (Node2 _ a b) p = let !sp = size p in case b of
Node2 sxy x y -> Deep s pr m (Two a (Node3 (sxy + sp) x y p))
Node3 sxyz x y z -> Deep s pr m (Three a (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
where !sz = size z
delRebuildRightSide s pr m (Node3 _ a b c) p = let !sp = size p in case c of
Node2 sxy x y -> Deep s pr m (Three a b (Node3 (sxy + sp) x y p))
Node3 sxyz x y z -> Deep s pr m (Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))
where !sz = size z
delRebuildMiddle :: Sized a
=> Int -> Digit a -> a -> Digit a
-> FingerTree a
delRebuildMiddle s (One a) e sf = Deep s (Two a e) EmptyT sf
delRebuildMiddle s (Two a b) e sf = Deep s (Three a b e) EmptyT sf
delRebuildMiddle s (Three a b c) e sf = Deep s (Four a b c e) EmptyT sf
delRebuildMiddle s (Four a b c d) e sf = Deep s (Two a b) (Single (node3 c d e)) sf
data DelDig a = FullDig !(Digit (Node a)) | DefectDig a
{-# SPECIALIZE delDigit :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Digit (Node (Elem a)) -> DelDig (Elem a) #-}
{-# SPECIALIZE delDigit :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Digit (Node (Node a)) -> DelDig (Node a) #-}
delDigit :: Sized a => (Int -> Node a -> Del a) -> Int -> Digit (Node a) -> DelDig a
delDigit f !i (One a) = case f i a of
Full a' -> FullDig $ One a'
Defect e -> DefectDig e
delDigit f i (Two a b)
| i < sa = case f i a of
Full a' -> FullDig $ Two a' b
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> FullDig $ Two (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)
where !sx = size x
Node2 sxy x y -> FullDig $ One (Node3 (se + sxy) e x y)
| otherwise = case f (i - sa) b of
Full b' -> FullDig $ Two a b'
Defect e -> let !se = size e in case a of
Node3 sxyz x y z -> FullDig $ Two (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
where !sz = size z
Node2 sxy x y -> FullDig $ One (Node3 (sxy + se) x y e)
where sa = size a
delDigit f i (Three a b c)
| i < sa = case f i a of
Full a' -> FullDig $ Three a' b c
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> FullDig $ Three (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c
where !sx = size x
Node2 sxy x y -> FullDig $ Two (Node3 (se + sxy) e x y) c
| i < sab = case f (i - sa) b of
Full b' -> FullDig $ Three a b' c
Defect e -> let !se = size e in case a of
Node3 sxyz x y z -> FullDig $ Three (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c
where !sz = size z
Node2 sxy x y -> FullDig $ Two (Node3 (sxy + se) x y e) c
| otherwise = case f (i - sab) c of
Full c' -> FullDig $ Three a b c'
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> FullDig $ Three a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
where !sz = size z
Node2 sxy x y -> FullDig $ Two a (Node3 (sxy + se) x y e)
where sa = size a
sab = sa + size b
delDigit f i (Four a b c d)
| i < sa = case f i a of
Full a' -> FullDig $ Four a' b c d
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> FullDig $ Four (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c d
where !sx = size x
Node2 sxy x y -> FullDig $ Three (Node3 (se + sxy) e x y) c d
| i < sab = case f (i - sa) b of
Full b' -> FullDig $ Four a b' c d
Defect e -> let !se = size e in case a of
Node3 sxyz x y z -> FullDig $ Four (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c d
where !sz = size z
Node2 sxy x y -> FullDig $ Three (Node3 (sxy + se) x y e) c d
| i < sabc = case f (i - sab) c of
Full c' -> FullDig $ Four a b c' d
Defect e -> let !se = size e in case b of
Node3 sxyz x y z -> FullDig $ Four a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) d
where !sz = size z
Node2 sxy x y -> FullDig $ Three a (Node3 (sxy + se) x y e) d
| otherwise = case f (i - sabc) d of
Full d' -> FullDig $ Four a b c d'
Defect e -> let !se = size e in case c of
Node3 sxyz x y z -> FullDig $ Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)
where !sz = size z
Node2 sxy x y -> FullDig $ Three a b (Node3 (sxy + se) x y e)
where sa = size a
sab = sa + size b
sabc = sab + size c
mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b
mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'
where
{-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}
{-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}
mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b
mapWithIndexTree _ !_s EmptyT = EmptyT
mapWithIndexTree f s (Single xs) = Single $ f s xs
mapWithIndexTree f s (Deep n pr m sf) =
Deep n
(mapWithIndexDigit f s pr)
(mapWithIndexTree (mapWithIndexNode f) sPspr m)
(mapWithIndexDigit f sPsprm sf)
where
!sPspr = s + size pr
!sPsprm = sPspr + size m
{-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}
{-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}
mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b
mapWithIndexDigit f !s (One a) = One (f s a)
mapWithIndexDigit f s (Two a b) = Two (f s a) (f sPsa b)
where
!sPsa = s + size a
mapWithIndexDigit f s (Three a b c) =
Three (f s a) (f sPsa b) (f sPsab c)
where
!sPsa = s + size a
!sPsab = sPsa + size b
mapWithIndexDigit f s (Four a b c d) =
Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)
where
!sPsa = s + size a
!sPsab = sPsa + size b
!sPsabc = sPsab + size c
{-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}
{-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}
mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b
mapWithIndexNode f s (Node2 ns a b) = Node2 ns (f s a) (f sPsa b)
where
!sPsa = s + size a
mapWithIndexNode f s (Node3 ns a b c) =
Node3 ns (f s a) (f sPsa b) (f sPsab c)
where
!sPsa = s + size a
!sPsab = sPsa + size b
#ifdef __GLASGOW_HASKELL__
{-# NOINLINE [1] mapWithIndex #-}
{-# RULES
"mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =
mapWithIndex (\k a -> f k (g k a)) xs
"mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =
mapWithIndex (\k a -> f k (g a)) xs
"fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =
mapWithIndex (\k a -> f (g k a)) xs
#-}
#endif
{-# INLINE foldWithIndexDigit #-}
foldWithIndexDigit :: Sized a => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b
foldWithIndexDigit _ f !s (One a) = f s a
foldWithIndexDigit (<+>) f s (Two a b) = f s a <+> f sPsa b
where
!sPsa = s + size a
foldWithIndexDigit (<+>) f s (Three a b c) = f s a <+> f sPsa b <+> f sPsab c
where
!sPsa = s + size a
!sPsab = sPsa + size b
foldWithIndexDigit (<+>) f s (Four a b c d) =
f s a <+> f sPsa b <+> f sPsab c <+> f sPsabc d
where
!sPsa = s + size a
!sPsab = sPsa + size b
!sPsabc = sPsab + size c
{-# INLINE foldWithIndexNode #-}
foldWithIndexNode :: Sized a => (m -> m -> m) -> (Int -> a -> m) -> Int -> Node a -> m
foldWithIndexNode (<+>) f !s (Node2 _ a b) = f s a <+> f sPsa b
where
!sPsa = s + size a
foldWithIndexNode (<+>) f s (Node3 _ a b c) = f s a <+> f sPsa b <+> f sPsab c
where
!sPsa = s + size a
!sPsab = sPsa + size b
foldMapWithIndex :: Monoid m => (Int -> a -> m) -> Seq a -> m
foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs'
where
lift_elem :: (Int -> a -> m) -> (Int -> Elem a -> m)
#if __GLASGOW_HASKELL__ >= 708
lift_elem g = coerce g
#else
lift_elem g = \s (Elem a) -> g s a
#endif
{-# INLINE lift_elem #-}
foldMapWithIndexTreeE :: Monoid m => (Int -> Elem a -> m) -> Int -> FingerTree (Elem a) -> m
foldMapWithIndexTreeE _ !_s EmptyT = mempty
foldMapWithIndexTreeE f s (Single xs) = f s xs
foldMapWithIndexTreeE f s (Deep _ pr m sf) =
foldMapWithIndexDigitE f s pr <>
foldMapWithIndexTreeN (foldMapWithIndexNodeE f) sPspr m <>
foldMapWithIndexDigitE f sPsprm sf
where
!sPspr = s + size pr
!sPsprm = sPspr + size m
foldMapWithIndexTreeN :: Monoid m => (Int -> Node a -> m) -> Int -> FingerTree (Node a) -> m
foldMapWithIndexTreeN _ !_s EmptyT = mempty
foldMapWithIndexTreeN f s (Single xs) = f s xs
foldMapWithIndexTreeN f s (Deep _ pr m sf) =
foldMapWithIndexDigitN f s pr <>
foldMapWithIndexTreeN (foldMapWithIndexNodeN f) sPspr m <>
foldMapWithIndexDigitN f sPsprm sf
where
!sPspr = s + size pr
!sPsprm = sPspr + size m
foldMapWithIndexDigitE :: Monoid m => (Int -> Elem a -> m) -> Int -> Digit (Elem a) -> m
foldMapWithIndexDigitE f i t = foldWithIndexDigit (<>) f i t
foldMapWithIndexDigitN :: Monoid m => (Int -> Node a -> m) -> Int -> Digit (Node a) -> m
foldMapWithIndexDigitN f i t = foldWithIndexDigit (<>) f i t
foldMapWithIndexNodeE :: Monoid m => (Int -> Elem a -> m) -> Int -> Node (Elem a) -> m
foldMapWithIndexNodeE f i t = foldWithIndexNode (<>) f i t
foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m
foldMapWithIndexNodeN f i t = foldWithIndexNode (<>) f i t
#if __GLASGOW_HASKELL__
{-# INLINABLE foldMapWithIndex #-}
#endif
traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) -> Elem <$> f' s a) 0 xs'
where
traverseWithIndexTreeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> FingerTree (Elem a) -> f (FingerTree b)
traverseWithIndexTreeE _ !_s EmptyT = pure EmptyT
traverseWithIndexTreeE f s (Single xs) = Single <$> f s xs
traverseWithIndexTreeE f s (Deep n pr m sf) =
liftA3 (Deep n)
(traverseWithIndexDigitE f s pr)
(traverseWithIndexTreeN (traverseWithIndexNodeE f) sPspr m)
(traverseWithIndexDigitE f sPsprm sf)
where
!sPspr = s + size pr
!sPsprm = sPspr + size m
traverseWithIndexTreeN :: Applicative f => (Int -> Node a -> f b) -> Int -> FingerTree (Node a) -> f (FingerTree b)
traverseWithIndexTreeN _ !_s EmptyT = pure EmptyT
traverseWithIndexTreeN f s (Single xs) = Single <$> f s xs
traverseWithIndexTreeN f s (Deep n pr m sf) =
liftA3 (Deep n)
(traverseWithIndexDigitN f s pr)
(traverseWithIndexTreeN (traverseWithIndexNodeN f) sPspr m)
(traverseWithIndexDigitN f sPsprm sf)
where
!sPspr = s + size pr
!sPsprm = sPspr + size m
traverseWithIndexDigitE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Digit (Elem a) -> f (Digit b)
traverseWithIndexDigitE f i t = traverseWithIndexDigit f i t
traverseWithIndexDigitN :: Applicative f => (Int -> Node a -> f b) -> Int -> Digit (Node a) -> f (Digit b)
traverseWithIndexDigitN f i t = traverseWithIndexDigit f i t
{-# INLINE traverseWithIndexDigit #-}
traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Digit a -> f (Digit b)
traverseWithIndexDigit f !s (One a) = One <$> f s a
traverseWithIndexDigit f s (Two a b) = liftA2 Two (f s a) (f sPsa b)
where
!sPsa = s + size a
traverseWithIndexDigit f s (Three a b c) =
liftA3 Three (f s a) (f sPsa b) (f sPsab c)
where
!sPsa = s + size a
!sPsab = sPsa + size b
traverseWithIndexDigit f s (Four a b c d) =
liftA3 Four (f s a) (f sPsa b) (f sPsab c) <*> f sPsabc d
where
!sPsa = s + size a
!sPsab = sPsa + size b
!sPsabc = sPsab + size c
traverseWithIndexNodeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Node (Elem a) -> f (Node b)
traverseWithIndexNodeE f i t = traverseWithIndexNode f i t
traverseWithIndexNodeN :: Applicative f => (Int -> Node a -> f b) -> Int -> Node (Node a) -> f (Node b)
traverseWithIndexNodeN f i t = traverseWithIndexNode f i t
{-# INLINE traverseWithIndexNode #-}
traverseWithIndexNode :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Node a -> f (Node b)
traverseWithIndexNode f !s (Node2 ns a b) = liftA2 (Node2 ns) (f s a) (f sPsa b)
where
!sPsa = s + size a
traverseWithIndexNode f s (Node3 ns a b c) =
liftA3 (Node3 ns) (f s a) (f sPsa b) (f sPsab c)
where
!sPsa = s + size a
!sPsab = sPsa + size b
{-# NOINLINE [1] traverseWithIndex #-}
#ifdef __GLASGOW_HASKELL__
{-# RULES
"travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =
traverseWithIndex (\k a -> f k (g k a)) xs
"travWithIndex/fmapSeq" forall f g xs . traverseWithIndex f (fmapSeq g xs) =
traverseWithIndex (\k a -> f k (g a)) xs
#-}
#endif
fromFunction :: Int -> (Int -> a) -> Seq a
fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"
| len == 0 = empty
| otherwise = Seq $ create (lift_elem f) 1 0 len
where
create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a
create b !s !i trees = case trees of
1 -> Single $ b i
2 -> Deep (2*s) (One (b i)) EmptyT (One (b (i+s)))
3 -> Deep (3*s) (createTwo i) EmptyT (One (b (i+2*s)))
4 -> Deep (4*s) (createTwo i) EmptyT (createTwo (i+2*s))
5 -> Deep (5*s) (createThree i) EmptyT (createTwo (i+3*s))
6 -> Deep (6*s) (createThree i) EmptyT (createThree (i+3*s))
_ -> case trees `quotRem` 3 of
(trees', 1) -> Deep (trees*s) (createTwo i)
(create mb (3*s) (i+2*s) (trees'-1))
(createTwo (i+(2+3*(trees'-1))*s))
(trees', 2) -> Deep (trees*s) (createThree i)
(create mb (3*s) (i+3*s) (trees'-1))
(createTwo (i+(3+3*(trees'-1))*s))
(trees', _) -> Deep (trees*s) (createThree i)
(create mb (3*s) (i+3*s) (trees'-2))
(createThree (i+(3+3*(trees'-2))*s))
where
createTwo j = Two (b j) (b (j + s))
{-# INLINE createTwo #-}
createThree j = Three (b j) (b (j + s)) (b (j + 2*s))
{-# INLINE createThree #-}
mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))
{-# INLINE mb #-}
lift_elem :: (Int -> a) -> (Int -> Elem a)
#if __GLASGOW_HASKELL__ >= 708
lift_elem g = coerce g
#else
lift_elem g = Elem . g
#endif
{-# INLINE lift_elem #-}
fromArray :: Ix i => Array i a -> Seq a
#ifdef __GLASGOW_HASKELL__
fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)
where
_ = Data.Array.rangeSize (Data.Array.bounds a)
#else
fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)
#endif
take :: Int -> Seq a -> Seq a
take i xs@(Seq t)
| fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =
Seq (takeTreeE i t)
| i <= 0 = empty
| otherwise = xs
takeTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)
takeTreeE !_i EmptyT = EmptyT
takeTreeE i t@(Single _)
| i <= 0 = EmptyT
| otherwise = t
takeTreeE i (Deep s pr m sf)
| i < spr = takePrefixE i pr
| i < spm = case takeTreeN im m of
ml :*: xs -> takeMiddleE (im - size ml) spr pr ml xs
| otherwise = takeSuffixE (i - spm) s pr m sf
where
spr = size pr
spm = spr + size m
im = i - spr
takeTreeN :: Int -> FingerTree (Node a) -> StrictPair (FingerTree (Node a)) (Node a)
takeTreeN !_i EmptyT = error "takeTreeN of empty tree"
takeTreeN _i (Single x) = EmptyT :*: x
takeTreeN i (Deep s pr m sf)
| i < spr = takePrefixN i pr
| i < spm = case takeTreeN im m of
ml :*: xs -> takeMiddleN (im - size ml) spr pr ml xs
| otherwise = takeSuffixN (i - spm) s pr m sf where
spr = size pr
spm = spr + size m
im = i - spr
takeMiddleN :: Int -> Int
-> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a)
-> StrictPair (FingerTree (Node a)) (Node a)
takeMiddleN i spr pr ml (Node2 _ a b)
| i < sa = pullR sprml pr ml :*: a
| otherwise = Deep sprmla pr ml (One a) :*: b
where
sa = size a
sprml = spr + size ml
sprmla = sa + sprml
takeMiddleN i spr pr ml (Node3 _ a b c)
| i < sa = pullR sprml pr ml :*: a
| i < sab = Deep sprmla pr ml (One a) :*: b
| otherwise = Deep sprmlab pr ml (Two a b) :*: c
where
sa = size a
sab = sa + size b
sprml = spr + size ml
sprmla = sa + sprml
sprmlab = sprmla + size b
takeMiddleE :: Int -> Int
-> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a)
-> FingerTree (Elem a)
takeMiddleE i spr pr ml (Node2 _ a _)
| i < 1 = pullR sprml pr ml
| otherwise = Deep sprmla pr ml (One a)
where
sprml = spr + size ml
sprmla = 1 + sprml
takeMiddleE i spr pr ml (Node3 _ a b _)
| i < 1 = pullR sprml pr ml
| i < 2 = Deep sprmla pr ml (One a)
| otherwise = Deep sprmlab pr ml (Two a b)
where
sprml = spr + size ml
sprmla = 1 + sprml
sprmlab = sprmla + 1
takePrefixE :: Int -> Digit (Elem a) -> FingerTree (Elem a)
takePrefixE !_i (One _) = EmptyT
takePrefixE i (Two a _)
| i < 1 = EmptyT
| otherwise = Single a
takePrefixE i (Three a b _)
| i < 1 = EmptyT
| i < 2 = Single a
| otherwise = Deep 2 (One a) EmptyT (One b)
takePrefixE i (Four a b c _)
| i < 1 = EmptyT
| i < 2 = Single a
| i < 3 = Deep 2 (One a) EmptyT (One b)
| otherwise = Deep 3 (Two a b) EmptyT (One c)
takePrefixN :: Int -> Digit (Node a)
-> StrictPair (FingerTree (Node a)) (Node a)
takePrefixN !_i (One a) = EmptyT :*: a
takePrefixN i (Two a b)
| i < sa = EmptyT :*: a
| otherwise = Single a :*: b
where
sa = size a
takePrefixN i (Three a b c)
| i < sa = EmptyT :*: a
| i < sab = Single a :*: b
| otherwise = Deep sab (One a) EmptyT (One b) :*: c
where
sa = size a
sab = sa + size b
takePrefixN i (Four a b c d)
| i < sa = EmptyT :*: a
| i < sab = Single a :*: b
| i < sabc = Deep sab (One a) EmptyT (One b) :*: c
| otherwise = Deep sabc (Two a b) EmptyT (One c) :*: d
where
sa = size a
sab = sa + size b
sabc = sab + size c
takeSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
FingerTree (Elem a)
takeSuffixE !_i !s pr m (One _) = pullR (s - 1) pr m
takeSuffixE i s pr m (Two a _)
| i < 1 = pullR (s - 2) pr m
| otherwise = Deep (s - 1) pr m (One a)
takeSuffixE i s pr m (Three a b _)
| i < 1 = pullR (s - 3) pr m
| i < 2 = Deep (s - 2) pr m (One a)
| otherwise = Deep (s - 1) pr m (Two a b)
takeSuffixE i s pr m (Four a b c _)
| i < 1 = pullR (s - 4) pr m
| i < 2 = Deep (s - 3) pr m (One a)
| i < 3 = Deep (s - 2) pr m (Two a b)
| otherwise = Deep (s - 1) pr m (Three a b c)
takeSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
StrictPair (FingerTree (Node a)) (Node a)
takeSuffixN !_i !s pr m (One a) = pullR (s - size a) pr m :*: a
takeSuffixN i s pr m (Two a b)
| i < sa = pullR (s - sa - size b) pr m :*: a
| otherwise = Deep (s - size b) pr m (One a) :*: b
where
sa = size a
takeSuffixN i s pr m (Three a b c)
| i < sa = pullR (s - sab - size c) pr m :*: a
| i < sab = Deep (s - size b - size c) pr m (One a) :*: b
| otherwise = Deep (s - size c) pr m (Two a b) :*: c
where
sa = size a
sab = sa + size b
takeSuffixN i s pr m (Four a b c d)
| i < sa = pullR (s - sa - sbcd) pr m :*: a
| i < sab = Deep (s - sbcd) pr m (One a) :*: b
| i < sabc = Deep (s - scd) pr m (Two a b) :*: c
| otherwise = Deep (s - sd) pr m (Three a b c) :*: d
where
sa = size a
sab = sa + size b
sabc = sab + size c
sd = size d
scd = size c + sd
sbcd = size b + scd
drop :: Int -> Seq a -> Seq a
drop i xs@(Seq t)
| fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =
Seq (takeTreeER (length xs - i) t)
| i <= 0 = xs
| otherwise = empty
takeTreeER :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)
takeTreeER !_i EmptyT = EmptyT
takeTreeER i t@(Single _)
| i <= 0 = EmptyT
| otherwise = t
takeTreeER i (Deep s pr m sf)
| i < ssf = takeSuffixER i sf
| i < ssm = case takeTreeNR im m of
xs :*: mr -> takeMiddleER (im - size mr) ssf xs mr sf
| otherwise = takePrefixER (i - ssm) s pr m sf
where
ssf = size sf
ssm = ssf + size m
im = i - ssf
takeTreeNR :: Int -> FingerTree (Node a) -> StrictPair (Node a) (FingerTree (Node a))
takeTreeNR !_i EmptyT = error "takeTreeNR of empty tree"
takeTreeNR _i (Single x) = x :*: EmptyT
takeTreeNR i (Deep s pr m sf)
| i < ssf = takeSuffixNR i sf
| i < ssm = case takeTreeNR im m of
xs :*: mr -> takeMiddleNR (im - size mr) ssf xs mr sf
| otherwise = takePrefixNR (i - ssm) s pr m sf where
ssf = size sf
ssm = ssf + size m
im = i - ssf
takeMiddleNR :: Int -> Int
-> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)
-> StrictPair (Node a) (FingerTree (Node a))
takeMiddleNR i ssf (Node2 _ a b) mr sf
| i < sb = b :*: pullL ssfmr mr sf
| otherwise = a :*: Deep ssfmrb (One b) mr sf
where
sb = size b
ssfmr = ssf + size mr
ssfmrb = sb + ssfmr
takeMiddleNR i ssf (Node3 _ a b c) mr sf
| i < sc = c :*: pullL ssfmr mr sf
| i < sbc = b :*: Deep ssfmrc (One c) mr sf
| otherwise = a :*: Deep ssfmrbc (Two b c) mr sf
where
sc = size c
sbc = sc + size b
ssfmr = ssf + size mr
ssfmrc = sc + ssfmr
ssfmrbc = ssfmrc + size b
takeMiddleER :: Int -> Int
-> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)
-> FingerTree (Elem a)
takeMiddleER i ssf (Node2 _ _ b) mr sf
| i < 1 = pullL ssfmr mr sf
| otherwise = Deep ssfmrb (One b) mr sf
where
ssfmr = ssf + size mr
ssfmrb = 1 + ssfmr
takeMiddleER i ssf (Node3 _ _ b c) mr sf
| i < 1 = pullL ssfmr mr sf
| i < 2 = Deep ssfmrc (One c) mr sf
| otherwise = Deep ssfmrbc (Two b c) mr sf
where
ssfmr = ssf + size mr
ssfmrc = 1 + ssfmr
ssfmrbc = ssfmr + 2
takeSuffixER :: Int -> Digit (Elem a) -> FingerTree (Elem a)
takeSuffixER !_i (One _) = EmptyT
takeSuffixER i (Two _ b)
| i < 1 = EmptyT
| otherwise = Single b
takeSuffixER i (Three _ b c)
| i < 1 = EmptyT
| i < 2 = Single c
| otherwise = Deep 2 (One b) EmptyT (One c)
takeSuffixER i (Four _ b c d)
| i < 1 = EmptyT
| i < 2 = Single d
| i < 3 = Deep 2 (One c) EmptyT (One d)
| otherwise = Deep 3 (Two b c) EmptyT (One d)
takeSuffixNR :: Int -> Digit (Node a)
-> StrictPair (Node a) (FingerTree (Node a))
takeSuffixNR !_i (One a) = a :*: EmptyT
takeSuffixNR i (Two a b)
| i < sb = b :*: EmptyT
| otherwise = a :*: Single b
where
sb = size b
takeSuffixNR i (Three a b c)
| i < sc = c :*: EmptyT
| i < sbc = b :*: Single c
| otherwise = a :*: Deep sbc (One b) EmptyT (One c)
where
sc = size c
sbc = sc + size b
takeSuffixNR i (Four a b c d)
| i < sd = d :*: EmptyT
| i < scd = c :*: Single d
| i < sbcd = b :*: Deep scd (One c) EmptyT (One d)
| otherwise = a :*: Deep sbcd (Two b c) EmptyT (One d)
where
sd = size d
scd = sd + size c
sbcd = scd + size b
takePrefixER :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
FingerTree (Elem a)
takePrefixER !_i !s (One _) m sf = pullL (s - 1) m sf
takePrefixER i s (Two _ b) m sf
| i < 1 = pullL (s - 2) m sf
| otherwise = Deep (s - 1) (One b) m sf
takePrefixER i s (Three _ b c) m sf
| i < 1 = pullL (s - 3) m sf
| i < 2 = Deep (s - 2) (One c) m sf
| otherwise = Deep (s - 1) (Two b c) m sf
takePrefixER i s (Four _ b c d) m sf
| i < 1 = pullL (s - 4) m sf
| i < 2 = Deep (s - 3) (One d) m sf
| i < 3 = Deep (s - 2) (Two c d) m sf
| otherwise = Deep (s - 1) (Three b c d) m sf
takePrefixNR :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
StrictPair (Node a) (FingerTree (Node a))
takePrefixNR !_i !s (One a) m sf = a :*: pullL (s - size a) m sf
takePrefixNR i s (Two a b) m sf
| i < sb = b :*: pullL (s - sb - size a) m sf
| otherwise = a :*: Deep (s - size a) (One b) m sf
where
sb = size b
takePrefixNR i s (Three a b c) m sf
| i < sc = c :*: pullL (s - sbc - size a) m sf
| i < sbc = b :*: Deep (s - size b - size a) (One c) m sf
| otherwise = a :*: Deep (s - size a) (Two b c) m sf
where
sc = size c
sbc = sc + size b
takePrefixNR i s (Four a b c d) m sf
| i < sd = d :*: pullL (s - sd - sabc) m sf
| i < scd = c :*: Deep (s - sabc) (One d) m sf
| i < sbcd = b :*: Deep (s - sab) (Two c d) m sf
| otherwise = a :*: Deep (s - sa) (Three b c d) m sf
where
sa = size a
sab = sa + size b
sabc = sab + size c
sd = size d
scd = size c + sd
sbcd = size b + scd
splitAt :: Int -> Seq a -> (Seq a, Seq a)
splitAt i xs@(Seq t)
| fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =
case splitTreeE i t of
l :*: r -> (Seq l, Seq r)
| i <= 0 = (empty, xs)
| otherwise = (xs, empty)
uncheckedSplitAt :: Int -> Seq a -> (Seq a, Seq a)
uncheckedSplitAt i (Seq xs) = case splitTreeE i xs of
l :*: r -> (Seq l, Seq r)
data Split a = Split !(FingerTree (Node a)) !(Node a) !(FingerTree (Node a))
#ifdef TESTING
deriving Show
#endif
splitTreeE :: Int -> FingerTree (Elem a) -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
splitTreeE !_i EmptyT = EmptyT :*: EmptyT
splitTreeE i t@(Single _)
| i <= 0 = EmptyT :*: t
| otherwise = t :*: EmptyT
splitTreeE i (Deep s pr m sf)
| i < spr = splitPrefixE i s pr m sf
| i < spm = case splitTreeN im m of
Split ml xs mr -> splitMiddleE (im - size ml) s spr pr ml xs mr sf
| otherwise = splitSuffixE (i - spm) s pr m sf
where
spr = size pr
spm = spr + size m
im = i - spr
splitTreeN :: Int -> FingerTree (Node a) -> Split a
splitTreeN !_i EmptyT = error "splitTreeN of empty tree"
splitTreeN _i (Single x) = Split EmptyT x EmptyT
splitTreeN i (Deep s pr m sf)
| i < spr = splitPrefixN i s pr m sf
| i < spm = case splitTreeN im m of
Split ml xs mr -> splitMiddleN (im - size ml) s spr pr ml xs mr sf
| otherwise = splitSuffixN (i - spm) s pr m sf where
spr = size pr
spm = spr + size m
im = i - spr
splitMiddleN :: Int -> Int -> Int
-> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)
-> Split a
splitMiddleN i s spr pr ml (Node2 _ a b) mr sf
| i < sa = Split (pullR sprml pr ml) a (Deep (s - sprmla) (One b) mr sf)
| otherwise = Split (Deep sprmla pr ml (One a)) b (pullL (s - sprmla - size b) mr sf)
where
sa = size a
sprml = spr + size ml
sprmla = sa + sprml
splitMiddleN i s spr pr ml (Node3 _ a b c) mr sf
| i < sa = Split (pullR sprml pr ml) a (Deep (s - sprmla) (Two b c) mr sf)
| i < sab = Split (Deep sprmla pr ml (One a)) b (Deep (s - sprmlab) (One c) mr sf)
| otherwise = Split (Deep sprmlab pr ml (Two a b)) c (pullL (s - sprmlab - size c) mr sf)
where
sa = size a
sab = sa + size b
sprml = spr + size ml
sprmla = sa + sprml
sprmlab = sprmla + size b
splitMiddleE :: Int -> Int -> Int
-> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)
-> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
splitMiddleE i s spr pr ml (Node2 _ a b) mr sf
| i < 1 = pullR sprml pr ml :*: Deep (s - sprml) (Two a b) mr sf
| otherwise = Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (One b) mr sf
where
sprml = spr + size ml
sprmla = 1 + sprml
splitMiddleE i s spr pr ml (Node3 _ a b c) mr sf = case i of
0 -> pullR sprml pr ml :*: Deep (s - sprml) (Three a b c) mr sf
1 -> Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (Two b c) mr sf
_ -> Deep sprmlab pr ml (Two a b) :*: Deep (s - sprmlab) (One c) mr sf
where
sprml = spr + size ml
sprmla = 1 + sprml
sprmlab = sprmla + 1
splitPrefixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
splitPrefixE !_i !s (One a) m sf = EmptyT :*: Deep s (One a) m sf
splitPrefixE i s (Two a b) m sf = case i of
0 -> EmptyT :*: Deep s (Two a b) m sf
_ -> Single a :*: Deep (s - 1) (One b) m sf
splitPrefixE i s (Three a b c) m sf = case i of
0 -> EmptyT :*: Deep s (Three a b c) m sf
1 -> Single a :*: Deep (s - 1) (Two b c) m sf
_ -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (One c) m sf
splitPrefixE i s (Four a b c d) m sf = case i of
0 -> EmptyT :*: Deep s (Four a b c d) m sf
1 -> Single a :*: Deep (s - 1) (Three b c d) m sf
2 -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (Two c d) m sf
_ -> Deep 3 (Two a b) EmptyT (One c) :*: Deep (s - 3) (One d) m sf
splitPrefixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
Split a
splitPrefixN !_i !s (One a) m sf = Split EmptyT a (pullL (s - size a) m sf)
splitPrefixN i s (Two a b) m sf
| i < sa = Split EmptyT a (Deep (s - sa) (One b) m sf)
| otherwise = Split (Single a) b (pullL (s - sa - size b) m sf)
where
sa = size a
splitPrefixN i s (Three a b c) m sf
| i < sa = Split EmptyT a (Deep (s - sa) (Two b c) m sf)
| i < sab = Split (Single a) b (Deep (s - sab) (One c) m sf)
| otherwise = Split (Deep sab (One a) EmptyT (One b)) c (pullL (s - sab - size c) m sf)
where
sa = size a
sab = sa + size b
splitPrefixN i s (Four a b c d) m sf
| i < sa = Split EmptyT a $ Deep (s - sa) (Three b c d) m sf
| i < sab = Split (Single a) b $ Deep (s - sab) (Two c d) m sf
| i < sabc = Split (Deep sab (One a) EmptyT (One b)) c $ Deep (s - sabc) (One d) m sf
| otherwise = Split (Deep sabc (Two a b) EmptyT (One c)) d $ pullL (s - sabc - size d) m sf
where
sa = size a
sab = sa + size b
sabc = sab + size c
splitSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->
StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))
splitSuffixE !_i !s pr m (One a) = pullR (s - 1) pr m :*: Single a
splitSuffixE i s pr m (Two a b) = case i of
0 -> pullR (s - 2) pr m :*: Deep 2 (One a) EmptyT (One b)
_ -> Deep (s - 1) pr m (One a) :*: Single b
splitSuffixE i s pr m (Three a b c) = case i of
0 -> pullR (s - 3) pr m :*: Deep 3 (Two a b) EmptyT (One c)
1 -> Deep (s - 2) pr m (One a) :*: Deep 2 (One b) EmptyT (One c)
_ -> Deep (s - 1) pr m (Two a b) :*: Single c
splitSuffixE i s pr m (Four a b c d) = case i of
0 -> pullR (s - 4) pr m :*: Deep 4 (Two a b) EmptyT (Two c d)
1 -> Deep (s - 3) pr m (One a) :*: Deep 3 (Two b c) EmptyT (One d)
2 -> Deep (s - 2) pr m (Two a b) :*: Deep 2 (One c) EmptyT (One d)
_ -> Deep (s - 1) pr m (Three a b c) :*: Single d
splitSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->
Split a
splitSuffixN !_i !s pr m (One a) = Split (pullR (s - size a) pr m) a EmptyT
splitSuffixN i s pr m (Two a b)
| i < sa = Split (pullR (s - sa - size b) pr m) a (Single b)
| otherwise = Split (Deep (s - size b) pr m (One a)) b EmptyT
where
sa = size a
splitSuffixN i s pr m (Three a b c)
| i < sa = Split (pullR (s - sab - size c) pr m) a (deep (One b) EmptyT (One c))
| i < sab = Split (Deep (s - size b - size c) pr m (One a)) b (Single c)
| otherwise = Split (Deep (s - size c) pr m (Two a b)) c EmptyT
where
sa = size a
sab = sa + size b
splitSuffixN i s pr m (Four a b c d)
| i < sa = Split (pullR (s - sa - sbcd) pr m) a (Deep sbcd (Two b c) EmptyT (One d))
| i < sab = Split (Deep (s - sbcd) pr m (One a)) b (Deep scd (One c) EmptyT (One d))
| i < sabc = Split (Deep (s - scd) pr m (Two a b)) c (Single d)
| otherwise = Split (Deep (s - sd) pr m (Three a b c)) d EmptyT
where
sa = size a
sab = sa + size b
sabc = sab + size c
sd = size d
scd = size c + sd
sbcd = size b + scd
chunksOf :: Int -> Seq a -> Seq (Seq a)
chunksOf n xs | n <= 0 =
if null xs
then empty
else error "chunksOf: A non-empty sequence can only be broken up into positively-sized chunks."
chunksOf 1 s = fmap singleton s
chunksOf n s = splitMap (uncheckedSplitAt . (*n)) const most (replicate numReps ())
>< if null end then empty else singleton end
where
(numReps, endLength) = length s `quotRem` n
(most, end) = splitAt (length s - endLength) s
tails :: Seq a -> Seq (Seq a)
tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty
inits :: Seq a -> Seq (Seq a)
inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)
tailsDigit :: Digit a -> Digit (Digit a)
tailsDigit (One a) = One (One a)
tailsDigit (Two a b) = Two (Two a b) (One b)
tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)
tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)
initsDigit :: Digit a -> Digit (Digit a)
initsDigit (One a) = One (One a)
initsDigit (Two a b) = Two (One a) (Two a b)
initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)
initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)
tailsNode :: Node a -> Node (Digit a)
tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)
tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)
initsNode :: Node a -> Node (Digit a)
initsNode (Node2 s a b) = Node2 s (One a) (Two a b)
initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)
{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
tailsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b
tailsTree _ EmptyT = EmptyT
tailsTree f (Single x) = Single (f (Single x))
tailsTree f (Deep n pr m sf) =
Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))
(tailsTree f' m)
(fmap (f . digitToTree) (tailsDigit sf))
where
f' ms = let ConsLTree node m' = viewLTree ms in
fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)
{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}
{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}
initsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b
initsTree _ EmptyT = EmptyT
initsTree f (Single x) = Single (f (Single x))
initsTree f (Deep n pr m sf) =
Deep n (fmap (f . digitToTree) (initsDigit pr))
(initsTree f' m)
(fmap (f . deep pr m) (initsDigit sf))
where
f' ms = let SnocRTree m' node = viewRTree ms in
fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)
{-# INLINE foldlWithIndex #-}
foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
foldlWithIndex f z xs = foldl (\ g x !i -> f (g (i - 1)) i x) (const z) xs (length xs - 1)
{-# INLINE foldrWithIndex #-}
foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
foldrWithIndex f z xs = foldr (\ x g !i -> f i x (g (i+1))) (const z) xs 0
{-# INLINE listToMaybe' #-}
listToMaybe' :: [a] -> Maybe a
listToMaybe' = foldr (\ x _ -> Just x) Nothing
takeWhileL :: (a -> Bool) -> Seq a -> Seq a
takeWhileL p = fst . spanl p
takeWhileR :: (a -> Bool) -> Seq a -> Seq a
takeWhileR p = fst . spanr p
dropWhileL :: (a -> Bool) -> Seq a -> Seq a
dropWhileL p = snd . spanl p
dropWhileR :: (a -> Bool) -> Seq a -> Seq a
dropWhileR p = snd . spanr p
spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanl p = breakl (not . p)
spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
spanr p = breakr (not . p)
{-# INLINE breakl #-}
breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)
{-# INLINE breakr #-}
breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)
where flipPair (x, y) = (y, x)
partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
partition p = toPair . foldl' part (empty :*: empty)
where
part (xs :*: ys) x
| p x = (xs `snoc'` x) :*: ys
| otherwise = xs :*: (ys `snoc'` x)
filter :: (a -> Bool) -> Seq a -> Seq a
filter p = foldl' (\ xs x -> if p x then xs `snoc'` x else xs) empty
elemIndexL :: Eq a => a -> Seq a -> Maybe Int
elemIndexL x = findIndexL (x ==)
elemIndexR :: Eq a => a -> Seq a -> Maybe Int
elemIndexR x = findIndexR (x ==)
elemIndicesL :: Eq a => a -> Seq a -> [Int]
elemIndicesL x = findIndicesL (x ==)
elemIndicesR :: Eq a => a -> Seq a -> [Int]
elemIndicesR x = findIndicesR (x ==)
findIndexL :: (a -> Bool) -> Seq a -> Maybe Int
findIndexL p = listToMaybe' . findIndicesL p
findIndexR :: (a -> Bool) -> Seq a -> Maybe Int
findIndexR p = listToMaybe' . findIndicesR p
{-# INLINE findIndicesL #-}
findIndicesL :: (a -> Bool) -> Seq a -> [Int]
#if __GLASGOW_HASKELL__
findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in
foldrWithIndex g n xs)
#else
findIndicesL p xs = foldrWithIndex g [] xs
where g i x is = if p x then i:is else is
#endif
{-# INLINE findIndicesR #-}
findIndicesR :: (a -> Bool) -> Seq a -> [Int]
#if __GLASGOW_HASKELL__
findIndicesR p xs = build (\ c n ->
let g z i x = if p x then c i z else z in foldlWithIndex g n xs)
#else
findIndicesR p xs = foldlWithIndex g [] xs
where g is i x = if p x then i:is else is
#endif
fromList :: [a] -> Seq a
fromList = Seq . mkTree . map_elem
where
#ifdef __GLASGOW_HASKELL__
mkTree :: forall a' . [Elem a'] -> FingerTree (Elem a')
#else
mkTree :: [Elem a] -> FingerTree (Elem a)
#endif
mkTree [] = EmptyT
mkTree [x1] = Single x1
mkTree [x1, x2] = Deep 2 (One x1) EmptyT (One x2)
mkTree [x1, x2, x3] = Deep 3 (Two x1 x2) EmptyT (One x3)
mkTree [x1, x2, x3, x4] = Deep 4 (Two x1 x2) EmptyT (Two x3 x4)
mkTree [x1, x2, x3, x4, x5] = Deep 5 (Three x1 x2 x3) EmptyT (Two x4 x5)
mkTree [x1, x2, x3, x4, x5, x6] =
Deep 6 (Three x1 x2 x3) EmptyT (Three x4 x5 x6)
mkTree [x1, x2, x3, x4, x5, x6, x7] =
Deep 7 (Two x1 x2) (Single (Node3 3 x3 x4 x5)) (Two x6 x7)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8] =
Deep 8 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Two x7 x8)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9] =
Deep 9 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Three x7 x8 x9)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1] =
Deep 10 (Two x1 x2)
(Deep 6 (One (Node3 3 x3 x4 x5)) EmptyT (One (Node3 3 x6 x7 x8)))
(Two y0 y1)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1] =
Deep 11 (Three x1 x2 x3)
(Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))
(Two y0 y1)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2] =
Deep 12 (Three x1 x2 x3)
(Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))
(Three y0 y1 y2)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1, y2, y3, y4] =
Deep 13 (Two x1 x2)
(Deep 9 (Two (Node3 3 x3 x4 x5) (Node3 3 x6 x7 x8)) EmptyT (One (Node3 3 y0 y1 y2)))
(Two y3 y4)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4] =
Deep 14 (Three x1 x2 x3)
(Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))
(Two y3 y4)
mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4, y5] =
Deep 15 (Three x1 x2 x3)
(Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))
(Three y3 y4 y5)
mkTree (x1:x2:x3:x4:x5:x6:x7:x8:x9:y0:y1:y2:y3:y4:y5:y6:xs) =
mkTreeC cont 9 (getNodes 3 (Node3 3 y3 y4 y5) y6 xs)
where
d2 = Three x1 x2 x3
d1 = Three (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9) (Node3 3 y0 y1 y2)
#ifdef __GLASGOW_HASKELL__
cont :: (Digit (Node (Elem a')), Digit (Elem a')) -> FingerTree (Node (Node (Elem a'))) -> FingerTree (Elem a')
#endif
cont (!r1, !r2) !sub =
let !sub1 = Deep (9 + size r1 + size sub) d1 sub r1
in Deep (3 + size r2 + size sub1) d2 sub1 r2
getNodes :: forall a . Int
-> Node a
-> a
-> [a]
-> ListFinal (Node (Node a)) (Digit (Node a), Digit a)
getNodes !_ n1 x1 [] = LFinal (One n1, One x1)
getNodes _ n1 x1 [x2] = LFinal (One n1, Two x1 x2)
getNodes _ n1 x1 [x2, x3] = LFinal (One n1, Three x1 x2 x3)
getNodes s n1 x1 [x2, x3, x4] = LFinal (Two n1 (Node3 s x1 x2 x3), One x4)
getNodes s n1 x1 [x2, x3, x4, x5] = LFinal (Two n1 (Node3 s x1 x2 x3), Two x4 x5)
getNodes s n1 x1 [x2, x3, x4, x5, x6] = LFinal (Two n1 (Node3 s x1 x2 x3), Three x4 x5 x6)
getNodes s n1 x1 [x2, x3, x4, x5, x6, x7] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), One x7)
getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Two x7 x8)
getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8, x9] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Three x7 x8 x9)
getNodes s n1 x1 (x2:x3:x4:x5:x6:x7:x8:x9:x10:xs) = LCons n10 (getNodes s (Node3 s x7 x8 x9) x10 xs)
where !n2 = Node3 s x1 x2 x3
!n3 = Node3 s x4 x5 x6
!n10 = Node3 (3*s) n1 n2 n3
mkTreeC ::
#ifdef __GLASGOW_HASKELL__
forall a b c .
#endif
(b -> FingerTree (Node a) -> c)
-> Int
-> ListFinal (Node a) b
-> c
mkTreeC cont !_ (LFinal b) =
cont b EmptyT
mkTreeC cont _ (LCons x1 (LFinal b)) =
cont b (Single x1)
mkTreeC cont s (LCons x1 (LCons x2 (LFinal b))) =
cont b (Deep (2*s) (One x1) EmptyT (One x2))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LFinal b)))) =
cont b (Deep (3*s) (Two x1 x2) EmptyT (One x3))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b))))) =
cont b (Deep (4*s) (Two x1 x2) EmptyT (Two x3 x4))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b)))))) =
cont b (Deep (5*s) (Three x1 x2 x3) EmptyT (Two x4 x5))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b))))))) =
cont b (Deep (6*s) (Three x1 x2 x3) EmptyT (Three x4 x5 x6))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b)))))))) =
cont b (Deep (7*s) (Two x1 x2) (Single (Node3 (3*s) x3 x4 x5)) (Two x6 x7))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b))))))))) =
cont b (Deep (8*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Two x7 x8))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b)))))))))) =
cont b (Deep (9*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Three x7 x8 x9))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LFinal b))))))))))) =
cont b (Deep (10*s) (Two x1 x2) (Deep (6*s) (One (Node3 (3*s) x3 x4 x5)) EmptyT (One (Node3 (3*s) x6 x7 x8))) (Two y0 y1))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LFinal b)))))))))))) =
cont b (Deep (11*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Two y0 y1))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LFinal b))))))))))))) =
cont b (Deep (12*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Three y0 y1 y2))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b)))))))))))))) =
cont b (Deep (13*s) (Two x1 x2) (Deep (9*s) (Two (Node3 (3*s) x3 x4 x5) (Node3 (3*s) x6 x7 x8)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b))))))))))))))) =
cont b (Deep (14*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LFinal b)))))))))))))))) =
cont b (Deep (15*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Three y3 y4 y5))
mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LCons y6 xs)))))))))))))))) =
mkTreeC cont2 (9*s) (getNodesC (3*s) (Node3 (3*s) y3 y4 y5) y6 xs)
where
#ifdef __GLASGOW_HASKELL__
cont2 :: (b, Digit (Node (Node a)), Digit (Node a)) -> FingerTree (Node (Node (Node a))) -> c
#endif
cont2 (b, r1, r2) !sub =
let d2 = Three x1 x2 x3
d1 = Three (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9) (Node3 (3*s) y0 y1 y2)
!sub1 = Deep (9*s + size r1 + size sub) d1 sub r1
in cont b $! Deep (3*s + size r2 + size sub1) d2 sub1 r2
getNodesC :: Int
-> Node a
-> a
-> ListFinal a b
-> ListFinal (Node (Node a)) (b, Digit (Node a), Digit a)
getNodesC !_ n1 x1 (LFinal b) = LFinal $ (b, One n1, One x1)
getNodesC _ n1 x1 (LCons x2 (LFinal b)) = LFinal $ (b, One n1, Two x1 x2)
getNodesC _ n1 x1 (LCons x2 (LCons x3 (LFinal b))) = LFinal $ (b, One n1, Three x1 x2 x3)
getNodesC s n1 x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b)))) =
let !n2 = Node3 s x1 x2 x3
in LFinal $ (b, Two n1 n2, One x4)
getNodesC s n1 x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b))))) =
let !n2 = Node3 s x1 x2 x3
in LFinal $ (b, Two n1 n2, Two x4 x5)
getNodesC s n1 x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b)))))) =
let !n2 = Node3 s x1 x2 x3
in LFinal $ (b, Two n1 n2, Three x4 x5 x6)
getNodesC s n1 x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b))))))) =
let !n2 = Node3 s x1 x2 x3
!n3 = Node3 s x4 x5 x6
in LFinal $ (b, Three n1 n2 n3, One x7)
getNodesC s n1 x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b)))))))) =
let !n2 = Node3 s x1 x2 x3
!n3 = Node3 s x4 x5 x6
in LFinal $ (b, Three n1 n2 n3, Two x7 x8)
getNodesC s n1 x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b))))))))) =
let !n2 = Node3 s x1 x2 x3
!n3 = Node3 s x4 x5 x6
in LFinal $ (b, Three n1 n2 n3, Three x7 x8 x9)
getNodesC s n1 x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons x10 xs))))))))) =
LCons n10 $ getNodesC s (Node3 s x7 x8 x9) x10 xs
where !n2 = Node3 s x1 x2 x3
!n3 = Node3 s x4 x5 x6
!n10 = Node3 (3*s) n1 n2 n3
map_elem :: [a] -> [Elem a]
#if __GLASGOW_HASKELL__ >= 708
map_elem xs = coerce xs
#else
map_elem xs = Data.List.map Elem xs
#endif
{-# INLINE map_elem #-}
data ListFinal a cont = LFinal !cont | LCons !a (ListFinal a cont)
#if __GLASGOW_HASKELL__ >= 708
instance GHC.Exts.IsList (Seq a) where
type Item (Seq a) = a
fromList = fromList
fromListN = fromList2
toList = toList
#endif
#ifdef __GLASGOW_HASKELL__
instance a ~ Char => IsString (Seq a) where
fromString = fromList
#endif
reverse :: Seq a -> Seq a
reverse (Seq xs) = Seq (fmapReverseTree id xs)
#ifdef __GLASGOW_HASKELL__
{-# NOINLINE [1] reverse #-}
fmapReverse :: (a -> b) -> Seq a -> Seq b
fmapReverse f (Seq xs) = Seq (fmapReverseTree (lift_elem f) xs)
where
lift_elem :: (a -> b) -> (Elem a -> Elem b)
#if __GLASGOW_HASKELL__ >= 708
lift_elem = coerce
#else
lift_elem g (Elem a) = Elem (g a)
#endif
{-# RULES
"fmapSeq/reverse" forall f xs . fmapSeq f (reverse xs) = fmapReverse f xs
"reverse/fmapSeq" forall f xs . reverse (fmapSeq f xs) = fmapReverse f xs
#-}
#endif
fmapReverseTree :: (a -> b) -> FingerTree a -> FingerTree b
fmapReverseTree _ EmptyT = EmptyT
fmapReverseTree f (Single x) = Single (f x)
fmapReverseTree f (Deep s pr m sf) =
Deep s (reverseDigit f sf)
(fmapReverseTree (reverseNode f) m)
(reverseDigit f pr)
{-# INLINE reverseDigit #-}
reverseDigit :: (a -> b) -> Digit a -> Digit b
reverseDigit f (One a) = One (f a)
reverseDigit f (Two a b) = Two (f b) (f a)
reverseDigit f (Three a b c) = Three (f c) (f b) (f a)
reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)
reverseNode :: (a -> b) -> Node a -> Node b
reverseNode f (Node2 s a b) = Node2 s (f b) (f a)
reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)
#ifdef __GLASGOW_HASKELL__
{-# INLINE splitMap #-}
splitMap :: forall s a' b' . (Int -> s -> (s,s)) -> (s -> a' -> b') -> s -> Seq a' -> Seq b'
splitMap splt f0 s0 (Seq xs0) = Seq $ splitMapTreeE (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0
where
{-# INLINE splitMapTreeE #-}
splitMapTreeE :: (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b
splitMapTreeE _ _ EmptyT = EmptyT
splitMapTreeE f s (Single xs) = Single $ f s xs
splitMapTreeE f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)
where
!spr = size pr
!sm = n - spr - size sf
(prs, r) = splt spr s
(ms, sfs) = splt sm r
splitMapTreeN :: (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b
splitMapTreeN _ _ EmptyT = EmptyT
splitMapTreeN f s (Single xs) = Single $ f s xs
splitMapTreeN f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)
where
(prs, r) = splt (size pr) s
(ms, sfs) = splt (size m) r
{-# INLINE splitMapDigit #-}
splitMapDigit :: Sized a => (s -> a -> b) -> s -> Digit a -> Digit b
splitMapDigit f s (One a) = One (f s a)
splitMapDigit f s (Two a b) = Two (f first a) (f second b)
where
(first, second) = splt (size a) s
splitMapDigit f s (Three a b c) = Three (f first a) (f second b) (f third c)
where
(first, r) = splt (size a) s
(second, third) = splt (size b) r
splitMapDigit f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)
where
(first, s') = splt (size a) s
(middle, fourth) = splt (size b + size c) s'
(second, third) = splt (size b) middle
{-# INLINE splitMapNode #-}
splitMapNode :: Sized a => (s -> a -> b) -> s -> Node a -> Node b
splitMapNode f s (Node2 ns a b) = Node2 ns (f first a) (f second b)
where
(first, second) = splt (size a) s
splitMapNode f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)
where
(first, r) = splt (size a) s
(second, third) = splt (size b) r
#else
{-# INLINE splitMap #-}
splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b
splitMap splt' f0 s0 (Seq xs0) = Seq $ splitMapTreeE splt' (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0
{-# INLINE splitMapTreeE #-}
splitMapTreeE :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b
splitMapTreeE _ _ _ EmptyT = EmptyT
splitMapTreeE _ f s (Single xs) = Single $ f s xs
splitMapTreeE splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)
where
!spr = size pr
sm = n - spr - size sf
(prs, r) = splt spr s
(ms, sfs) = splt sm r
splitMapTreeN :: (Int -> s -> (s,s)) -> (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b
splitMapTreeN _ _ _ EmptyT = EmptyT
splitMapTreeN _ f s (Single xs) = Single $ f s xs
splitMapTreeN splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)
where
(prs, r) = splt (size pr) s
(ms, sfs) = splt (size m) r
{-# INLINE splitMapDigit #-}
splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b
splitMapDigit _ f s (One a) = One (f s a)
splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)
where
(first, second) = splt (size a) s
splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)
where
(first, r) = splt (size a) s
(second, third) = splt (size b) r
splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)
where
(first, s') = splt (size a) s
(middle, fourth) = splt (size b + size c) s'
(second, third) = splt (size b) middle
{-# INLINE splitMapNode #-}
splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b
splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)
where
(first, second) = splt (size a) s
splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)
where
(first, r) = splt (size a) s
(second, third) = splt (size b) r
#endif
#if MIN_VERSION_base(4,4,0)
instance MonadZip Seq where
mzipWith = zipWith
munzip = unzip
#endif
unzip :: Seq (a, b) -> (Seq a, Seq b)
unzip xs = unzipWith id xs
unzipWith :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)
unzipWith f = unzipWith' (\x ->
let
{-# NOINLINE fx #-}
fx = f x
(y,z) = fx
in (y,z))
#ifdef __GLASGOW_HASKELL__
{-# NOINLINE [1] unzipWith #-}
{-# RULES
"unzipWith/fmapSeq" forall f g xs. unzipWith f (fmapSeq g xs) =
unzipWith (f . g) xs
#-}
#endif
class UnzipWith f where
unzipWith' :: (x -> (a, b)) -> f x -> (f a, f b)
instance UnzipWith Elem where
#if __GLASGOW_HASKELL__ >= 708
unzipWith' = coerce
#else
unzipWith' f (Elem a) = case f a of (x, y) -> (Elem x, Elem y)
#endif
instance UnzipWith Node where
unzipWith' f (Node2 s x y) =
( Node2 s x1 y1
, Node2 s x2 y2)
where
{-# NOINLINE fx #-}
{-# NOINLINE fy #-}
fx = strictifyPair (f x)
fy = strictifyPair (f y)
(x1, x2) = fx
(y1, y2) = fy
unzipWith' f (Node3 s x y z) =
( Node3 s x1 y1 z1
, Node3 s x2 y2 z2)
where
{-# NOINLINE fx #-}
{-# NOINLINE fy #-}
{-# NOINLINE fz #-}
fx = strictifyPair (f x)
fy = strictifyPair (f y)
fz = strictifyPair (f z)
(x1, x2) = fx
(y1, y2) = fy
(z1, z2) = fz
strictifyPair :: (a, b) -> (a, b)
strictifyPair (!x, !y) = (x, y)
instance UnzipWith Digit where
unzipWith' f (One x)
| (x1, x2) <- f x
= (One x1, One x2)
unzipWith' f (Two x y)
| (x1, x2) <- f x
, (y1, y2) <- f y
= ( Two x1 y1
, Two x2 y2)
unzipWith' f (Three x y z)
| (x1, x2) <- f x
, (y1, y2) <- f y
, (z1, z2) <- f z
= ( Three x1 y1 z1
, Three x2 y2 z2)
unzipWith' f (Four x y z w)
| (x1, x2) <- f x
, (y1, y2) <- f y
, (z1, z2) <- f z
, (w1, w2) <- f w
= ( Four x1 y1 z1 w1
, Four x2 y2 z2 w2)
instance UnzipWith FingerTree where
unzipWith' _ EmptyT = (EmptyT, EmptyT)
unzipWith' f (Single x)
| (x1, x2) <- f x
= (Single x1, Single x2)
unzipWith' f (Deep s pr m sf)
| (!pr1, !pr2) <- unzipWith' f pr
, (!sf1, !sf2) <- unzipWith' f sf
= (Deep s pr1 m1 sf1, Deep s pr2 m2 sf2)
where
{-# NOINLINE m1m2 #-}
m1m2 = strictifyPair $ unzipWith' (unzipWith' f) m
(m1, m2) = m1m2
instance UnzipWith Seq where
unzipWith' _ (Seq EmptyT) = (empty, empty)
unzipWith' f (Seq (Single (Elem x)))
| (x1, x2) <- f x
= (singleton x1, singleton x2)
unzipWith' f (Seq (Deep s pr m sf))
| (!pr1, !pr2) <- unzipWith' (unzipWith' f) pr
, (!sf1, !sf2) <- unzipWith' (unzipWith' f) sf
= (Seq (Deep s pr1 m1 sf1), Seq (Deep s pr2 m2 sf2))
where
{-# NOINLINE m1m2 #-}
m1m2 = strictifyPair $ unzipWith' (unzipWithNodeElem f) m
(m1, m2) = m1m2
unzipWithNodeElem :: (x -> (a, b))
-> Node (Elem x) -> (Node (Elem a), Node (Elem b))
unzipWithNodeElem f (Node2 s (Elem x) (Elem y))
| (x1, x2) <- f x
, (y1, y2) <- f y
= ( Node2 s (Elem x1) (Elem y1)
, Node2 s (Elem x2) (Elem y2))
unzipWithNodeElem f (Node3 s (Elem x) (Elem y) (Elem z))
| (x1, x2) <- f x
, (y1, y2) <- f y
, (z1, z2) <- f z
= ( Node3 s (Elem x1) (Elem y1) (Elem z1)
, Node3 s (Elem x2) (Elem y2) (Elem z2))
zip :: Seq a -> Seq b -> Seq (a, b)
zip = zipWith (,)
zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
zipWith f s1 s2 = zipWith' f s1' s2'
where
minLen = min (length s1) (length s2)
s1' = take minLen s1
s2' = take minLen s2
zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
zipWith' f s1 s2 = splitMap uncheckedSplitAt goLeaf s2 s1
where
goLeaf (Seq (Single (Elem b))) a = f a b
goLeaf _ _ = error "Data.Sequence.zipWith'.goLeaf internal error: not a singleton"
zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
zip3 = zipWith3 (,,)
zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'
where
minLen = minimum [length s1, length s2, length s3]
s1' = take minLen s1
s2' = take minLen s2
s3' = take minLen s3
zipWith3' :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
zipWith3' f s1 s2 s3 = zipWith' ($) (zipWith' f s1 s2) s3
zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)
zip4 = zipWith4 (,,,)
zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'
where
minLen = minimum [length s1, length s2, length s3, length s4]
s1' = take minLen s1
s2' = take minLen s2
s3' = take minLen s3
s4' = take minLen s4
fromList2 :: Int -> [a] -> Seq a
fromList2 n = execState (replicateA n (State ht))
where
ht (x:xs) = (xs, x)
ht [] = error "fromList2: short list"