{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE DeriveGeneric #-}
#endif
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE AutoDeriveTypeable #-}
#endif
module Data.FingerTree (
#if TESTING
FingerTree(..), Digit(..), Node(..), deep, node2, node3,
#else
FingerTree,
#endif
Measured(..),
empty, singleton,
(<|), (|>), (><),
fromList,
null,
ViewL(..), viewl,
ViewR(..), viewr,
SearchResult(..), search,
split, takeUntil, dropUntil,
reverse,
fmap', fmapWithPos, fmapWithContext, unsafeFmap,
traverse', traverseWithPos, traverseWithContext, unsafeTraverse,
) where
import Prelude hiding (null, reverse)
#if MIN_VERSION_base(4,6,0)
import GHC.Generics
#endif
#if MIN_VERSION_base(4,8,0)
import qualified Prelude (null)
#else
import Control.Applicative (Applicative(pure, (<*>)), (<$>))
import Data.Monoid
import Data.Foldable (Foldable(foldMap))
#endif
#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif
import Data.Foldable (toList)
infixr 5 ><
infixr 5 <|, :<
infixl 5 |>, :>
data ViewL s a
= EmptyL
| a :< s a
deriving (Eq, Ord, Show, Read
#if __GLASGOW_HASKELL__ >= 706
, Generic
#endif
)
data ViewR s a
= EmptyR
| s a :> a
deriving (Eq, Ord, Show, Read
#if __GLASGOW_HASKELL__ >= 706
, Generic
#endif
)
instance (Functor s) => Functor (ViewL s) where
fmap _ EmptyL = EmptyL
fmap f (x :< xs) = f x :< fmap f xs
instance (Functor s) => Functor (ViewR s) where
fmap _ EmptyR = EmptyR
fmap f (xs :> x) = fmap f xs :> f x
#if MIN_VERSION_base(4,9,0)
instance (Measured v a) => Semigroup (FingerTree v a) where
(<>) = (><)
#endif
instance (Measured v a) => Monoid (FingerTree v a) where
mempty = empty
#if !(MIN_VERSION_base(4,11,0))
mappend = (><)
#endif
data Digit a
= One a
| Two a a
| Three a a a
| Four a a a a
deriving (Show
#if __GLASGOW_HASKELL__ >= 706
, Generic
#endif
)
instance Foldable Digit where
foldMap f (One a) = f a
foldMap f (Two a b) = f a `mappend` f b
foldMap f (Three a b c) = f a `mappend` f b `mappend` f c
foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d
class (Monoid v) => Measured v a | a -> v where
measure :: a -> v
instance (Measured v a) => Measured v (Digit a) where
measure = foldMap measure
data Node v a = Node2 !v a a | Node3 !v a a a
deriving (Show
#if __GLASGOW_HASKELL__ >= 706
, Generic
#endif
)
instance Foldable (Node v) where
foldMap f (Node2 _ a b) = f a `mappend` f b
foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c
node2 :: (Measured v a) => a -> a -> Node v a
node2 a b = Node2 (measure a `mappend` measure b) a b
node3 :: (Measured v a) => a -> a -> a -> Node v a
node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c
instance (Monoid v) => Measured v (Node v a) where
measure (Node2 v _ _) = v
measure (Node3 v _ _ _) = v
nodeToDigit :: Node v a -> Digit a
nodeToDigit (Node2 _ a b) = Two a b
nodeToDigit (Node3 _ a b c) = Three a b c
data FingerTree v a
= Empty
| Single a
| Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)
#if TESTING
deriving (Show
#if __GLASGOW_HASKELL__ >= 706
, Generic
#endif
)
#elif __GLASGOW_HASKELL__ >= 706
deriving (Generic)
#endif
deep :: (Measured v a) =>
Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
deep pr m sf =
Deep ((measure pr `mappend` measure m) `mappend` measure sf) pr m sf
instance (Measured v a) => Measured v (FingerTree v a) where
measure Empty = mempty
measure (Single x) = measure x
measure (Deep v _ _ _) = v
instance Foldable (FingerTree v) where
foldMap _ Empty = mempty
foldMap f (Single x) = f x
foldMap f (Deep _ pr m sf) =
foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf
#if MIN_VERSION_base(4,8,0)
null Empty = True
null _ = False
#endif
instance (Eq a) => Eq (FingerTree v a) where
xs == ys = toList xs == toList ys
instance (Ord a) => Ord (FingerTree v a) where
compare xs ys = compare (toList xs) (toList ys)
#if !TESTING
instance (Show a) => Show (FingerTree v a) where
showsPrec p xs = showParen (p > 10) $
showString "fromList " . shows (toList xs)
#endif
fmap' :: (Measured v1 a1, Measured v2 a2) =>
(a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
fmap' = mapTree
mapTree :: (Measured v2 a2) =>
(a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
mapTree _ Empty = Empty
mapTree f (Single x) = Single (f x)
mapTree f (Deep _ pr m sf) =
deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf)
mapNode :: (Measured v2 a2) =>
(a1 -> a2) -> Node v1 a1 -> Node v2 a2
mapNode f (Node2 _ a b) = node2 (f a) (f b)
mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c)
mapDigit :: (a -> b) -> Digit a -> Digit b
mapDigit f (One a) = One (f a)
mapDigit f (Two a b) = Two (f a) (f b)
mapDigit f (Three a b c) = Three (f a) (f b) (f c)
mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d)
fmapWithPos :: (Measured v1 a1, Measured v2 a2) =>
(v1 -> a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
fmapWithPos f = mapWPTree f mempty
mapWPTree :: (Measured v1 a1, Measured v2 a2) =>
(v1 -> a1 -> a2) -> v1 -> FingerTree v1 a1 -> FingerTree v2 a2
mapWPTree _ _ Empty = Empty
mapWPTree f v (Single x) = Single (f v x)
mapWPTree f v (Deep _ pr m sf) =
deep (mapWPDigit f v pr)
(mapWPTree (mapWPNode f) vpr m)
(mapWPDigit f vm sf)
where
vpr = v `mappend` measure pr
vm = vpr `mappend` measure m
mapWPNode :: (Measured v1 a1, Measured v2 a2) =>
(v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2
mapWPNode f v (Node2 _ a b) = node2 (f v a) (f va b)
where
va = v `mappend` measure a
mapWPNode f v (Node3 _ a b c) = node3 (f v a) (f va b) (f vab c)
where
va = v `mappend` measure a
vab = va `mappend` measure b
mapWPDigit :: (Measured v a) => (v -> a -> b) -> v -> Digit a -> Digit b
mapWPDigit f v (One a) = One (f v a)
mapWPDigit f v (Two a b) = Two (f v a) (f va b)
where
va = v `mappend` measure a
mapWPDigit f v (Three a b c) = Three (f v a) (f va b) (f vab c)
where
va = v `mappend` measure a
vab = va `mappend` measure b
mapWPDigit f v (Four a b c d) = Four (f v a) (f va b) (f vab c) (f vabc d)
where
va = v `mappend` measure a
vab = va `mappend` measure b
vabc = vab `mappend` measure c
fmapWithContext :: (Measured v1 a1, Measured v2 a2) =>
(v1 -> a1 -> v1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
fmapWithContext f t = mapWCTree f mempty t mempty
mapWCTree :: (Measured v1 a1, Measured v2 a2) =>
(v1 -> a1 -> v1 -> a2) -> v1 -> FingerTree v1 a1 -> v1 -> FingerTree v2 a2
mapWCTree _ _ Empty _ = Empty
mapWCTree f vl (Single x) vr = Single (f vl x vr)
mapWCTree f vl (Deep _ pr m sf) vr =
deep (mapWCDigit f vl pr vmsr)
(mapWCTree (mapWCNode f) vlp m vsr)
(mapWCDigit f vlpm sf vr)
where
vlp = vl `mappend` measure pr
vlpm = vlp `mappend` vm
vmsr = vm `mappend` vsr
vsr = measure sf `mappend` vr
vm = measure m
mapWCNode :: (Measured v1 a1, Measured v2 a2) =>
(v1 -> a1 -> v1 -> a2) -> v1 -> Node v1 a1 -> v1 -> Node v2 a2
mapWCNode f vl (Node2 _ a b) vr = node2 (f vl a vb) (f va b vr)
where
va = vl `mappend` measure a
vb = measure b `mappend` vr
mapWCNode f vl (Node3 _ a b c) vr = node3 (f vl a vbc) (f va b vc) (f vab c vr)
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vbc = measure b `mappend` vc
vc = measure c `mappend` vr
mapWCDigit ::
(Measured v a) => (v -> a -> v -> b) -> v -> Digit a -> v -> Digit b
mapWCDigit f vl (One a) vr = One (f vl a vr)
mapWCDigit f vl (Two a b) vr = Two (f vl a vb) (f va b vr)
where
va = vl `mappend` measure a
vb = measure b `mappend` vr
mapWCDigit f vl (Three a b c) vr = Three (f vl a vbc) (f va b vc) (f vab c vr)
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vbc = measure b `mappend` vc
vc = measure c `mappend` vr
mapWCDigit f vl (Four a b c d) vr =
Four (f vl a vbcd) (f va b vcd) (f vab c vd) (f vabc d vr)
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vabc = vab `mappend` measure c
vbcd = measure b `mappend` vcd
vcd = measure c `mappend` vd
vd = measure d `mappend` vr
unsafeFmap :: (a -> b) -> FingerTree v a -> FingerTree v b
unsafeFmap _ Empty = Empty
unsafeFmap f (Single x) = Single (f x)
unsafeFmap f (Deep v pr m sf) =
Deep v (mapDigit f pr) (unsafeFmap (unsafeFmapNode f) m) (mapDigit f sf)
unsafeFmapNode :: (a -> b) -> Node v a -> Node v b
unsafeFmapNode f (Node2 v a b) = Node2 v (f a) (f b)
unsafeFmapNode f (Node3 v a b c) = Node3 v (f a) (f b) (f c)
traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
(a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
traverse' = traverseTree
traverseTree :: (Measured v2 a2, Applicative f) =>
(a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
traverseTree _ Empty = pure Empty
traverseTree f (Single x) = Single <$> f x
traverseTree f (Deep _ pr m sf) =
deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf
traverseNode :: (Measured v2 a2, Applicative f) =>
(a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2)
traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b
traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c
traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b)
traverseDigit f (One a) = One <$> f a
traverseDigit f (Two a b) = Two <$> f a <*> f b
traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c
traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d
traverseWithPos :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
(v1 -> a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
traverseWithPos f = traverseWPTree f mempty
traverseWPTree :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
(v1 -> a1 -> f a2) -> v1 -> FingerTree v1 a1 -> f (FingerTree v2 a2)
traverseWPTree _ _ Empty = pure Empty
traverseWPTree f v (Single x) = Single <$> f v x
traverseWPTree f v (Deep _ pr m sf) =
deep <$> traverseWPDigit f v pr <*> traverseWPTree (traverseWPNode f) vpr m <*> traverseWPDigit f vm sf
where
vpr = v `mappend` measure pr
vm = vpr `mappend` measure m
traverseWPNode :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
(v1 -> a1 -> f a2) -> v1 -> Node v1 a1 -> f (Node v2 a2)
traverseWPNode f v (Node2 _ a b) = node2 <$> f v a <*> f va b
where
va = v `mappend` measure a
traverseWPNode f v (Node3 _ a b c) = node3 <$> f v a <*> f va b <*> f vab c
where
va = v `mappend` measure a
vab = va `mappend` measure b
traverseWPDigit :: (Measured v a, Applicative f) =>
(v -> a -> f b) -> v -> Digit a -> f (Digit b)
traverseWPDigit f v (One a) = One <$> f v a
traverseWPDigit f v (Two a b) = Two <$> f v a <*> f va b
where
va = v `mappend` measure a
traverseWPDigit f v (Three a b c) = Three <$> f v a <*> f va b <*> f vab c
where
va = v `mappend` measure a
vab = va `mappend` measure b
traverseWPDigit f v (Four a b c d) = Four <$> f v a <*> f va b <*> f vab c <*> f vabc d
where
va = v `mappend` measure a
vab = va `mappend` measure b
vabc = vab `mappend` measure c
traverseWithContext :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
(v1 -> a1 -> v1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)
traverseWithContext f t = traverseWCTree f mempty t mempty
traverseWCTree :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
(v1 -> a1 -> v1 -> f a2) -> v1 -> FingerTree v1 a1 -> v1 -> f (FingerTree v2 a2)
traverseWCTree _ _ Empty _ = pure Empty
traverseWCTree f vl (Single x) vr = Single <$> f vl x vr
traverseWCTree f vl (Deep _ pr m sf) vr =
deep <$> traverseWCDigit f vl pr vmsr <*> traverseWCTree (traverseWCNode f) vlp m vsr <*> traverseWCDigit f vlpm sf vr
where
vlp = vl `mappend` measure pr
vlpm = vlp `mappend` vm
vmsr = vm `mappend` vsr
vsr = measure sf `mappend` vr
vm = measure m
traverseWCNode :: (Measured v1 a1, Measured v2 a2, Applicative f) =>
(v1 -> a1 -> v1 -> f a2) -> v1 -> Node v1 a1 -> v1 -> f (Node v2 a2)
traverseWCNode f vl (Node2 _ a b) vr = node2 <$> f vl a vb <*> f va b vr
where
va = vl `mappend` measure a
vb = measure a `mappend` vr
traverseWCNode f vl (Node3 _ a b c) vr =
node3 <$> f vl a vbc <*> f va b vc <*> f vab c vr
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vc = measure c `mappend` vr
vbc = measure b `mappend` vc
traverseWCDigit :: (Measured v a, Applicative f) =>
(v -> a -> v -> f b) -> v -> Digit a -> v -> f (Digit b)
traverseWCDigit f vl (One a) vr = One <$> f vl a vr
traverseWCDigit f vl (Two a b) vr = Two <$> f vl a vb <*> f va b vr
where
va = vl `mappend` measure a
vb = measure a `mappend` vr
traverseWCDigit f vl (Three a b c) vr =
Three <$> f vl a vbc <*> f va b vc <*> f vab c vr
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vc = measure c `mappend` vr
vbc = measure b `mappend` vc
traverseWCDigit f vl (Four a b c d) vr =
Four <$> f vl a vbcd <*> f va b vcd <*> f vab c vd <*> f vabc d vr
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vabc = vab `mappend` measure c
vd = measure d `mappend` vr
vcd = measure c `mappend` vd
vbcd = measure b `mappend` vcd
unsafeTraverse :: (Applicative f) =>
(a -> f b) -> FingerTree v a -> f (FingerTree v b)
unsafeTraverse _ Empty = pure Empty
unsafeTraverse f (Single x) = Single <$> f x
unsafeTraverse f (Deep v pr m sf) =
Deep v <$> traverseDigit f pr <*> unsafeTraverse (unsafeTraverseNode f) m <*> traverseDigit f sf
unsafeTraverseNode :: (Applicative f) =>
(a -> f b) -> Node v a -> f (Node v b)
unsafeTraverseNode f (Node2 v a b) = Node2 v <$> f a <*> f b
unsafeTraverseNode f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c
empty :: Measured v a => FingerTree v a
empty = Empty
singleton :: Measured v a => a -> FingerTree v a
singleton = Single
fromList :: (Measured v a) => [a] -> FingerTree v a
fromList = foldr (<|) Empty
(<|) :: (Measured v a) => a -> FingerTree v a -> FingerTree v a
a <| Empty = Single a
a <| Single b = deep (One a) Empty (One b)
a <| Deep v (Four b c d e) m sf = m `seq`
Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf
a <| Deep v pr m sf =
Deep (measure a `mappend` v) (consDigit a pr) m sf
consDigit :: a -> Digit a -> Digit a
consDigit a (One b) = Two a b
consDigit a (Two b c) = Three a b c
consDigit a (Three b c d) = Four a b c d
consDigit _ (Four _ _ _ _) = illegal_argument "consDigit"
(|>) :: (Measured v a) => FingerTree v a -> a -> FingerTree v a
Empty |> a = Single a
Single a |> b = deep (One a) Empty (One b)
Deep v pr m (Four a b c d) |> e = m `seq`
Deep (v `mappend` measure e) pr (m |> node3 a b c) (Two d e)
Deep v pr m sf |> x =
Deep (v `mappend` measure x) pr m (snocDigit sf x)
snocDigit :: Digit a -> a -> Digit a
snocDigit (One a) b = Two a b
snocDigit (Two a b) c = Three a b c
snocDigit (Three a b c) d = Four a b c d
snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit"
null :: FingerTree v a -> Bool
null Empty = True
null _ = False
viewl :: (Measured v a) => FingerTree v a -> ViewL (FingerTree v) a
viewl Empty = EmptyL
viewl (Single x) = x :< Empty
viewl (Deep _ (One x) m sf) = x :< rotL m sf
viewl (Deep _ pr m sf) = lheadDigit pr :< deep (ltailDigit pr) m sf
rotL :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> FingerTree v a
rotL m sf = case viewl m of
EmptyL -> digitToTree sf
a :< m' -> Deep (measure m `mappend` measure sf) (nodeToDigit a) m' sf
lheadDigit :: Digit a -> a
lheadDigit (One a) = a
lheadDigit (Two a _) = a
lheadDigit (Three a _ _) = a
lheadDigit (Four a _ _ _) = a
ltailDigit :: Digit a -> Digit a
ltailDigit (One _) = illegal_argument "ltailDigit"
ltailDigit (Two _ b) = One b
ltailDigit (Three _ b c) = Two b c
ltailDigit (Four _ b c d) = Three b c d
viewr :: (Measured v a) => FingerTree v a -> ViewR (FingerTree v) a
viewr Empty = EmptyR
viewr (Single x) = Empty :> x
viewr (Deep _ pr m (One x)) = rotR pr m :> x
viewr (Deep _ pr m sf) = deep pr m (rtailDigit sf) :> rheadDigit sf
rotR :: (Measured v a) => Digit a -> FingerTree v (Node v a) -> FingerTree v a
rotR pr m = case viewr m of
EmptyR -> digitToTree pr
m' :> a -> Deep (measure pr `mappend` measure m) pr m' (nodeToDigit a)
rheadDigit :: Digit a -> a
rheadDigit (One a) = a
rheadDigit (Two _ b) = b
rheadDigit (Three _ _ c) = c
rheadDigit (Four _ _ _ d) = d
rtailDigit :: Digit a -> Digit a
rtailDigit (One _) = illegal_argument "rtailDigit"
rtailDigit (Two a _) = One a
rtailDigit (Three a b _) = Two a b
rtailDigit (Four a b c _) = Three a b c
digitToTree :: (Measured v a) => Digit a -> FingerTree v a
digitToTree (One a) = Single a
digitToTree (Two a b) = deep (One a) Empty (One b)
digitToTree (Three a b c) = deep (Two a b) Empty (One c)
digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)
(><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
(><) = appendTree0
appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
appendTree0 Empty xs =
xs
appendTree0 xs Empty =
xs
appendTree0 (Single x) xs =
x <| xs
appendTree0 xs (Single x) =
xs |> x
appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =
deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2
addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v 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 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a
appendTree1 Empty a xs =
a <| xs
appendTree1 xs a Empty =
xs |> a
appendTree1 (Single x) a xs =
x <| a <| xs
appendTree1 xs a (Single x) =
xs |> a |> x
appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =
deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2
addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v 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 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a
appendTree2 Empty a b xs =
a <| b <| xs
appendTree2 xs a b Empty =
xs |> a |> b
appendTree2 (Single x) a b xs =
x <| a <| b <| xs
appendTree2 xs a b (Single x) =
xs |> a |> b |> x
appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =
deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2
addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v 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 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a
appendTree3 Empty a b c xs =
a <| b <| c <| xs
appendTree3 xs a b c Empty =
xs |> a |> b |> c
appendTree3 (Single x) a b c xs =
x <| a <| b <| c <| xs
appendTree3 xs a b c (Single x) =
xs |> a |> b |> c |> x
appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =
deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2
addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v 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 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a
appendTree4 Empty a b c d xs =
a <| b <| c <| d <| xs
appendTree4 xs a b c d Empty =
xs |> a |> b |> c |> d
appendTree4 (Single x) a b c d xs =
x <| a <| b <| c <| d <| xs
appendTree4 xs a b c d (Single x) =
xs |> a |> b |> c |> d |> x
appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =
deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2
addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v 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
data SearchResult v a
= Position (FingerTree v a) a (FingerTree v a)
| OnLeft
| OnRight
| Nowhere
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__ >= 706
, Generic
#endif
)
search :: (Measured v a) =>
(v -> v -> Bool) -> FingerTree v a -> SearchResult v a
search p t
| p_left && p_right = OnLeft
| not p_left && p_right = case searchTree p mempty t mempty of
Split l x r -> Position l x r
| not p_left && not p_right = OnRight
| otherwise = Nowhere
where
p_left = p mempty vt
p_right = p vt mempty
vt = measure t
searchTree :: (Measured v a) =>
(v -> v -> Bool) -> v -> FingerTree v a -> v -> Split (FingerTree v a) a
searchTree _ _ Empty _ = illegal_argument "searchTree"
searchTree _ _ (Single x) _ = Split Empty x Empty
searchTree p vl (Deep _ pr m sf) vr
| p vlp vmsr = let Split l x r = searchDigit p vl pr vmsr
in Split (maybe Empty digitToTree l) x (deepL r m sf)
| p vlpm vsr = let Split ml xs mr = searchTree p vlp m vsr
Split l x r = searchNode p (vlp `mappend` measure ml) xs (measure mr `mappend` vsr)
in Split (deepR pr ml l) x (deepL r mr sf)
| otherwise = let Split l x r = searchDigit p vlpm sf vr
in Split (deepR pr m l) x (maybe Empty digitToTree r)
where
vlp = vl `mappend` measure pr
vlpm = vlp `mappend` vm
vmsr = vm `mappend` vsr
vsr = measure sf `mappend` vr
vm = measure m
searchNode :: (Measured v a) =>
(v -> v -> Bool) -> v -> Node v a -> v -> Split (Maybe (Digit a)) a
searchNode p vl (Node2 _ a b) vr
| p va vb = Split Nothing a (Just (One b))
| otherwise = Split (Just (One a)) b Nothing
where
va = vl `mappend` measure a
vb = measure b `mappend` vr
searchNode p vl (Node3 _ a b c) vr
| p va vbc = Split Nothing a (Just (Two b c))
| p vab vc = Split (Just (One a)) b (Just (One c))
| otherwise = Split (Just (Two a b)) c Nothing
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vc = measure c `mappend` vr
vbc = measure b `mappend` vc
searchDigit :: (Measured v a) =>
(v -> v -> Bool) -> v -> Digit a -> v -> Split (Maybe (Digit a)) a
searchDigit _ vl (One a) vr = vl `seq` vr `seq` Split Nothing a Nothing
searchDigit p vl (Two a b) vr
| p va vb = Split Nothing a (Just (One b))
| otherwise = Split (Just (One a)) b Nothing
where
va = vl `mappend` measure a
vb = measure b `mappend` vr
searchDigit p vl (Three a b c) vr
| p va vbc = Split Nothing a (Just (Two b c))
| p vab vc = Split (Just (One a)) b (Just (One c))
| otherwise = Split (Just (Two a b)) c Nothing
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vbc = measure b `mappend` vc
vc = measure c `mappend` vr
searchDigit p vl (Four a b c d) vr
| p va vbcd = Split Nothing a (Just (Three b c d))
| p vab vcd = Split (Just (One a)) b (Just (Two c d))
| p vabc vd = Split (Just (Two a b)) c (Just (One d))
| otherwise = Split (Just (Three a b c)) d Nothing
where
va = vl `mappend` measure a
vab = va `mappend` measure b
vabc = vab `mappend` measure c
vbcd = measure b `mappend` vcd
vcd = measure c `mappend` vd
vd = measure d `mappend` vr
split :: (Measured v a) =>
(v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)
split _ Empty = (Empty, Empty)
split p xs
| p (measure xs) = (l, x <| r)
| otherwise = (xs, Empty)
where
Split l x r = splitTree p mempty xs
takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a
takeUntil p = fst . split p
dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a
dropUntil p = snd . split p
data Split t a = Split t a t
splitTree :: (Measured v a) =>
(v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a
splitTree _ _ Empty = illegal_argument "splitTree"
splitTree _ _ (Single x) = Split Empty x Empty
splitTree p i (Deep _ pr m sf)
| p vpr = let Split l x r = splitDigit p i pr
in Split (maybe Empty digitToTree l) x (deepL r m sf)
| p vm = let Split ml xs mr = splitTree p vpr m
Split l x r = splitNode p (vpr `mappend` measure ml) xs
in Split (deepR pr ml l) x (deepL r mr sf)
| otherwise = let Split l x r = splitDigit p vm sf
in Split (deepR pr m l) x (maybe Empty digitToTree r)
where
vpr = i `mappend` measure pr
vm = vpr `mappend` measure m
deepL :: (Measured v a) =>
Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
deepL Nothing m sf = rotL m sf
deepL (Just pr) m sf = deep pr m sf
deepR :: (Measured v a) =>
Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a
deepR pr m Nothing = rotR pr m
deepR pr m (Just sf) = deep pr m sf
splitNode :: (Measured v a) =>
(v -> Bool) -> v -> Node v a -> Split (Maybe (Digit a)) a
splitNode p i (Node2 _ a b)
| p va = Split Nothing a (Just (One b))
| otherwise = Split (Just (One a)) b Nothing
where
va = i `mappend` measure a
splitNode p i (Node3 _ a b c)
| p va = Split Nothing a (Just (Two b c))
| p vab = Split (Just (One a)) b (Just (One c))
| otherwise = Split (Just (Two a b)) c Nothing
where
va = i `mappend` measure a
vab = va `mappend` measure b
splitDigit :: (Measured v a) =>
(v -> Bool) -> v -> Digit a -> Split (Maybe (Digit a)) a
splitDigit _ i (One a) = i `seq` Split Nothing a Nothing
splitDigit p i (Two a b)
| p va = Split Nothing a (Just (One b))
| otherwise = Split (Just (One a)) b Nothing
where
va = i `mappend` measure a
splitDigit p i (Three a b c)
| p va = Split Nothing a (Just (Two b c))
| p vab = Split (Just (One a)) b (Just (One c))
| otherwise = Split (Just (Two a b)) c Nothing
where
va = i `mappend` measure a
vab = va `mappend` measure b
splitDigit p i (Four a b c d)
| p va = Split Nothing a (Just (Three b c d))
| p vab = Split (Just (One a)) b (Just (Two c d))
| p vabc = Split (Just (Two a b)) c (Just (One d))
| otherwise = Split (Just (Three a b c)) d Nothing
where
va = i `mappend` measure a
vab = va `mappend` measure b
vabc = vab `mappend` measure c
reverse :: (Measured v a) => FingerTree v a -> FingerTree v a
reverse = reverseTree id
reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2
reverseTree _ Empty = Empty
reverseTree f (Single x) = Single (f x)
reverseTree f (Deep _ pr m sf) =
deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr)
reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2
reverseNode f (Node2 _ a b) = node2 (f b) (f a)
reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a)
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)
illegal_argument :: String -> a
illegal_argument name =
error $ "Logic error: " ++ name ++ " called with illegal argument"