packages feed

fingertree 0.0.1.1 → 0.1.6.3

raw patch · 7 files changed

Files

Data/FingerTree.hs view
@@ -1,796 +1,1416 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Data.FingerTree--- Copyright   :  (c) Ross Paterson, Ralf Hinze 2006--- License     :  BSD-style--- Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  non-portable (MPTCs and functional dependencies)------ A general sequence representation with arbitrary annotations, for--- use as a base for implementations of various collection types, as--- described in section 4 of------    * Ralf Hinze and Ross Paterson,---      \"Finger trees: a simple general-purpose data structure\",---      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.---      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>------ For a directly usable sequence type, see @Data.Sequence@, which is--- a specialization of this structure.------ An amortized running time is given for each operation, with /n/--- referring to the length of the sequence.  These bounds hold even in--- a persistent (shared) setting.------ /Note/: Many of these operations have the same names as similar--- operations on lists in the "Prelude".  The ambiguity may be resolved--- using either qualification or the @hiding@ clause.-----------------------------------------------------------------------------------module Data.FingerTree (-	FingerTree,-	Measured(..),-	-- * Construction-	empty, singleton,-	(<|), (|>), (><),-	fromList,-	-- * Deconstruction-	null,-	ViewL(..), ViewR(..), viewl, viewr,-	split, takeUntil, dropUntil,-	-- * Transformation-	reverse,-	fmap', fmapWithPos, unsafeFmap,-	traverse', traverseWithPos, unsafeTraverse-	-- * Example-	-- $example-	) where--import Prelude hiding (null, reverse)--import Control.Applicative (Applicative(pure, (<*>)), (<$>))-import Data.Monoid-import Data.Foldable (Foldable(foldMap), toList)-import Data.Traversable (Traversable(traverse))--infixr 5 ><-infixr 5 <|, :<-infixl 5 |>, :>---- | View of the left end of a sequence.-data ViewL s a-	= EmptyL 	-- ^ empty sequence-	| a :< s a	-- ^ leftmost element and the rest of the sequence-	deriving (Eq, Ord, Show, Read)---- | View of the right end of a sequence.-data ViewR s a-	= EmptyR	-- ^ empty sequence-	| s a :> a	-- ^ the sequence minus the rightmost element,-			-- and the rightmost element-	deriving (Eq, Ord, Show, Read)--instance Functor s => Functor (ViewL s) where-	fmap f EmptyL           = EmptyL-	fmap f (x :< xs)        = f x :< fmap f xs--instance Functor s => Functor (ViewR s) where-	fmap f EmptyR           = EmptyR-	fmap f (xs :> x)        = fmap f xs :> f x--instance Measured v a => Monoid (FingerTree v a) where-	mempty = empty-	mappend = (><)---- Explicit Digit type (Exercise 1)--data Digit a-	= One a-	| Two a a-	| Three a a a-	| Four a a a a-	deriving Show--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------------------------ 4.1 Measurements------------------------ | Things that can be measured.-class (Monoid v) => Measured v a | a -> v where-	measure :: a -> v--instance (Measured v a) => Measured v (Digit a) where-	measure	=  foldMap measure-------------------------------- 4.2 Caching measurements------------------------------data Node v a = Node2 !v a a | Node3 !v a a a-	deriving Show--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---- | A representation of a sequence of values of type @a@, allowing--- access to the ends in constant time, and append and split in time--- logarithmic in the size of the smaller piece.------ The collection is also parameterized by a measure type @v@, which--- is used to specify a position in the sequence for the 'split' operation.--- The types of the operations enforce the constraint @'Measured' v a@,--- which also implies that the type @v@ is determined by @a@.------ A variety of abstract data types can be implemented by using different--- element types and measurements.-data FingerTree v a-	= Empty-	| Single a-	| Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)--deep ::  (Measured v a) => -	 Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a-deep pr m sf = Deep ((measure pr `mappendVal` 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--instance (Measured v a, Eq a) => Eq (FingerTree v a) where-	xs == ys = toList xs == toList ys--instance (Measured v a, Ord a) => Ord (FingerTree v a) where-	compare xs ys = compare (toList xs) (toList ys)--instance (Measured v a, Show a) => Show (FingerTree v a) where-	showsPrec p xs = showParen (p > 10) $-		showString "fromList " . shows (toList xs)---- | Like 'fmap', but with a more constrained type.-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)---- | Map all elements of the tree with a function that also takes the--- measure of the prefix of the tree to the left of the element.-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  `mappendVal` 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---- | Like 'fmap', but safe only if the function preserves the measure.-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)---- | Like 'traverse', but with a more constrained type.-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---- | Traverse the tree with a function that also takes the--- measure of the prefix of the tree to the left of the element.-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  `mappendVal` 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---- | Like 'traverse', but safe only if the function preserves the measure.-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---------------------------------------------------------- 4.3 Construction, deconstruction and concatenation---------------------------------------------------------- | /O(1)/. The empty sequence.-empty :: Measured v a => FingerTree v a-empty = Empty---- | /O(1)/. A singleton sequence.-singleton :: Measured v a => a -> FingerTree v a-singleton = Single---- | /O(n)/. Create a sequence from a finite list of elements.-fromList :: (Measured v a) => [a] -> FingerTree v a -fromList = foldr (<|) Empty---- | /O(1)/. Add an element to the left end of a sequence.--- Mnemonic: a triangle with the single element at the pointy end.-(<|) :: (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---- | /O(1)/. Add an element to the right end of a sequence.--- Mnemonic: a triangle with the single element at the pointy end.-(|>) :: (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---- | /O(1)/. Is this the empty sequence?-null :: (Measured v a) => FingerTree v a -> Bool-null Empty = True-null _ = False---- | /O(1)/. Analyse the left end of a sequence.-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 (Two _ b) = One b-ltailDigit (Three _ b c) = Two b c-ltailDigit (Four _ b c d) = Three b c d- --- | /O(1)/. Analyse the right end of a sequence.-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 `mappendVal` 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 (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)--------------------- Concatenation--------------------- | /O(log(min(n1,n2)))/. Concatenate two sequences.-(><) :: (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--------------------- 4.4 Splitting--------------------- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate--- on the accumulated measure changes from 'False' to 'True'.------ For predictable results, one should ensure that there is only one such--- point, i.e. that the predicate is /monotonic/.-split ::  (Measured v a) => -          (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)-split _p Empty  =  (Empty, Empty)-split p xs-  | p (measure xs) =  (l, x <| r)-  | otherwise	=  (xs, Empty)-  where Split l x r = splitTree p mempty xs---- | /O(log(min(i,n-i)))/.--- Given a monotonic predicate @p@, @'takeUntil' p t@ is the largest--- prefix of @t@ whose measure does not satisfy @p@.------ *  @'takeUntil' p t = 'fst' ('split' p t)@-takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a-takeUntil p  =  fst . split p---- | /O(log(min(i,n-i)))/.--- Given a monotonic predicate @p@, @'dropUntil' p t@ is the rest of @t@--- after removing the largest prefix whose measure does not satisfy @p@.------ * @'dropUntil' p t = 'snd' ('split' p t)@-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 _p _i (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 `mappendVal` 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  `mappendVal` m---- Avoid relying on right identity (cf Exercise 7)-mappendVal :: (Measured v a) => v -> FingerTree v a -> v-mappendVal v Empty = v-mappendVal v t = v `mappend` measure t--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 p 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----------------------- Transformations----------------------- | /O(n)/. The reverse of a sequence.-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)--{- $example--Particular abstract data types may be implemented by defining-element types with suitable 'Measured' instances.--(from section 4.5 of the paper)-Simple sequences can be implemented using a 'Sum' monoid as a measure:+{-# 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 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE DeriveAnyClass #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.FingerTree+-- Copyright   :  Ross Paterson and Ralf Hinze 2006,+--                Ross Paterson 2006-2022,+--                James Cranch 2021+-- License     :  BSD-style+-- Maintainer  :  R.Paterson@city.ac.uk+-- Stability   :  experimental+-- Portability :  non-portable (MPTCs and functional dependencies)+--+-- A general sequence representation with arbitrary annotations, for+-- use as a base for implementations of various collection types, as+-- described in section 4 of+--+--  * Ralf Hinze and Ross Paterson,+--    \"Finger trees: a simple general-purpose data structure\",+--    /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+--    <https://staff.city.ac.uk/~ross/papers/FingerTree.html>+--+-- For a directly usable sequence type, see @Data.Sequence@, which is+-- a specialization of this structure.+--+-- An amortized running time is given for each operation, with /n/+-- referring to the length of the sequence.  These bounds hold even in+-- a persistent (shared) setting.+--+-- /Note/: Many of these operations have the same names as similar+-- operations on lists in the "Prelude".  The ambiguity may be resolved+-- using either qualification or the @hiding@ clause.+--+-----------------------------------------------------------------------------++module Data.FingerTree (+#if TESTING+    FingerTree(..), Digit(..), Node(..), deep, node2, node3,+#else+    FingerTree,+#endif+    Measured(..),+    -- * Construction+    empty, singleton,+    (<|), (|>), (><),+    fromList,+    -- * Deconstruction+    null,+    -- ** Examining the ends+    ViewL(..), viewl,+    ViewR(..), viewr,+    -- ** Search+    SearchResult(..), search,+    -- ** Splitting+    -- | These functions are special cases of 'search'.+    split, takeUntil, dropUntil,+    -- * Transformation+    reverse,+    -- ** Maps+    fmap', fmapWithPos, fmapWithContext, unsafeFmap,+    -- ** Folds+    foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext,+    -- ** Traversals+    traverse', traverseWithPos, traverseWithContext, unsafeTraverse,+    -- * Example+    -- $example+    ) 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+#endif+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Foldable (Foldable(foldMap))+#endif+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Control.DeepSeq+import Data.Foldable (toList)++infixr 5 ><+infixr 5 <|, :<+infixl 5 |>, :>++-- | View of the left end of a sequence.+data ViewL s a+    = EmptyL        -- ^ empty sequence+    | a :< s a      -- ^ leftmost element and the rest of the sequence+    deriving (Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 706+        , Generic+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#endif+        )++-- | View of the right end of a sequence.+data ViewR s a+    = EmptyR        -- ^ empty sequence+    | s a :> a      -- ^ the sequence minus the rightmost element,+                    -- and the rightmost element+    deriving (Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 706+        , Generic+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#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++-- | 'empty' and '><'.+instance (Measured v a) => Monoid (FingerTree v a) where+    mempty = empty+#if !(MIN_VERSION_base(4,11,0))+    mappend = (><)+#endif++-- Explicit Digit type (Exercise 1)++data Digit a+    = One a+    | Two a a+    | Three a a a+    | Four a a a a+    deriving (Show+#if __GLASGOW_HASKELL__ >= 706+        , Generic+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#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++-------------------+-- 4.1 Measurements+-------------------++-- | Things that can be measured.+class (Monoid v) => Measured v a | a -> v where+    measure :: a -> v++instance (Measured v a) => Measured v (Digit a) where+    measure = foldMap measure++---------------------------+-- 4.2 Caching measurements+---------------------------++data Node v a = Node2 !v a a | Node3 !v a a a+    deriving (Show+#if __GLASGOW_HASKELL__ >= 706+        , Generic+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#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++-- | A representation of a sequence of values of type @a@, allowing+-- access to the ends in constant time, and append and split in time+-- logarithmic in the size of the smaller piece.+--+-- The collection is also parameterized by a measure type @v@, which+-- is used to specify a position in the sequence for the 'split' operation.+-- The types of the operations enforce the constraint @'Measured' v a@,+-- which also implies that the type @v@ is determined by @a@.+--+-- A variety of abstract data types can be implemented by using different+-- element types and measurements.+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+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#endif+        )+#elif __GLASGOW_HASKELL__ >= 710+    deriving (Generic, NFData)+#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++-- | /O(1)/. The cached measure of a tree.+instance (Measured v a) => Measured v (FingerTree v a) where+    measure Empty           =  mempty+    measure (Single x)      =  measure x+    measure (Deep v _ _ _)  =  v++-- | Elements from left to right.+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++-- | Lexicographical order from left to right.+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++-- | Like 'fmap', but with constraints on the element types.+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)++-- | Map all elements of the tree with a function that also takes the+-- measure of the prefix of the tree to the left of the element.+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 vl (Single x) = Single (f vl x)+mapWPTree f vl (Deep _ pr m sf) =+    deep (mapWPDigit f vl pr)+         (mapWPTree (mapWPNode f) vlp m)+         (mapWPDigit f vlpm sf)+  where+    vlp     =  vl `mappend` measure pr+    vlpm    =  vlp `mappend` measure m++mapWPNode :: (Measured v1 a1, Measured v2 a2) =>+    (v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2+mapWPNode f vl (Node2 _ a b) = node2 (f vl a) (f vla b)+  where+    vla     =  vl `mappend` measure a+mapWPNode f vl (Node3 _ a b c) = node3 (f vl a) (f vla b) (f vlab c)+  where+    va      =  vl `mappend` measure a+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b++mapWPDigit :: (Measured v a) => (v -> a -> b) -> v -> Digit a -> Digit b+mapWPDigit f vl (One a) = One (f vl a)+mapWPDigit f vl (Two a b) = Two (f vl a) (f vla b)+  where+    vla     =  vl `mappend` measure a+mapWPDigit f vl (Three a b c) = Three (f vl a) (f vla b) (f vlab c)+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+mapWPDigit f vl (Four a b c d) = Four (f vl a) (f vla b) (f vlab c) (f vlabc d)+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vlabc   =  vlab `mappend` measure c++-- | Map all elements of the tree with a function that also takes the+-- measure of the prefix to the left and of the suffix to the right of+-- the element.+--+-- @since 0.1.2.0+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 vbr) (f vla b vr)+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+mapWCNode f vl (Node3 _ a b c) vr =+    node3 (f vl a vbcr) (f vla b vcr) (f vlab c vr)+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr++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 vbr) (f vla b vr)+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+mapWCDigit f vl (Three a b c) vr =+    Three (f vl a vbcr) (f vla b vcr) (f vlab c vr)+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr+mapWCDigit f vl (Four a b c d) vr =+    Four (f vl a vbcdr) (f vla b vcdr) (f vlab c vdr) (f vlabc d vr)+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vlabc   =  vlab `mappend` measure c+    vdr     =  measure d `mappend` vr+    vcdr    =  measure c `mappend` vdr+    vbcdr   =  measure b `mappend` vcdr++-- | Like 'fmap', but safe only if the function preserves the measure.+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)++-- | Fold the tree from the left with a function that also takes the+-- measure of the prefix to the left of the element.+--+-- @since 0.1.5.0+foldlWithPos :: (Measured v a) =>+    (b -> v -> a -> b) -> b -> FingerTree v a -> b+foldlWithPos f z = foldlWPTree f z mempty++foldlWPTree :: (Measured v a) =>+    (b -> v -> a -> b) -> b -> v -> FingerTree v a -> b+foldlWPTree _ z _ Empty = z+foldlWPTree f z vl (Single x) = f z vl x+foldlWPTree f z vl (Deep _ pr m sf) = zpms+  where+    vlp     =  vl `mappend` measure pr+    vlpm    =  vlp `mappend` measure m+    zp      =  foldlWPDigit f z vl pr+    zpm     =  foldlWPTree (foldlWPNode f) zp vlp m+    zpms    =  foldlWPDigit f zpm vlpm sf++foldlWPNode :: (Measured v a) =>+    (b -> v -> a -> b) -> b -> v -> Node v a -> b+foldlWPNode f z vl (Node2 _ a b) = f (f z vl a) vla b+  where+    vla     =  vl `mappend` measure a+foldlWPNode f z vl (Node3 _ a b c) = f (f (f z vl a) vla b) vlab c+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b++foldlWPDigit :: (Measured v a) =>+    (b -> v -> a -> b) -> b -> v -> Digit a -> b+foldlWPDigit f z vl (One a) = f z vl a+foldlWPDigit f z vl (Two a b) = f (f z vl a) vla b+  where+    vla     =  vl `mappend` measure a+foldlWPDigit f z vl (Three a b c) = f (f (f z vl a) vla b) vlab c+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+foldlWPDigit f z vl (Four a b c d) = f (f (f (f z vl a) vla b) vlab c) vlabc d+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vlabc   =  vlab `mappend` measure c++-- | Fold the tree from the right with a function that also takes the+-- measure of the prefix to the left of the element.+--+-- @since 0.1.5.0+foldrWithPos :: (Measured v a) =>+    (v -> a -> b -> b) -> b -> FingerTree v a -> b+foldrWithPos f z = foldrWPTree f z mempty++foldrWPTree :: (Measured v a) =>+    (v -> a -> b -> b) -> b -> v -> FingerTree v a -> b+foldrWPTree _ z _ Empty = z+foldrWPTree f z vl (Single x) = f vl x z+foldrWPTree f z vl (Deep _ pr m sf) = zpms+  where+    vlp     =  vl `mappend` measure pr+    vlpm    =  vlp `mappend` measure m+    zpms    =  foldrWPDigit f zms vl pr+    zms     =  foldrWPTree (foldrWPNode f) zs vlp m+    zs      =  foldrWPDigit f z vlpm sf++-- different argument order for convenience+foldrWPNode :: (Measured v a) =>+    (v -> a -> b -> b) -> v -> Node v a -> b -> b+foldrWPNode f vl (Node2 _ a b) z = f vl a (f vla b z)+  where+    vla     =  vl `mappend` measure a+foldrWPNode f vl (Node3 _ a b c) z = f vl a (f vla b (f vlab c z))+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b++foldrWPDigit :: (Measured v a) =>+    (v -> a -> b -> b) -> b -> v -> Digit a -> b+foldrWPDigit f z vl (One a) = f vl a z+foldrWPDigit f z vl (Two a b) = f vl a (f vla b z)+  where+    vla     =  vl `mappend` measure a+foldrWPDigit f z vl (Three a b c) = f vl a (f vla b (f vlab c z))+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+foldrWPDigit f z vl (Four a b c d) = f vl a (f vla b (f vlab c (f vlabc d z)))+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vlabc   =  vlab `mappend` measure c++-- | Fold the tree from the left with a function that also takes the+-- measure of the prefix to the left of the element and the measure of+-- the suffix to the right of the element.+--+-- @since 0.1.5.0+foldlWithContext :: (Measured v a) =>+    (b -> v -> a -> v -> b) -> b -> FingerTree v a -> b+foldlWithContext f z t = foldlWCTree f z mempty t mempty++foldlWCTree :: (Measured v a) =>+    (b -> v -> a -> v -> b) -> b -> v -> FingerTree v a -> v -> b+foldlWCTree _ z _ Empty _ = z+foldlWCTree f z vl (Single x) vr = f z vl x vr+foldlWCTree f z vl (Deep _ pr m sf) vr = zpms+  where+    vlp     =  vl `mappend` measure pr+    vlpm    =  vlp `mappend` vm+    vmsr    =  vm `mappend` vsr+    vsr     =  measure sf `mappend` vr+    vm      =  measure m+    zp      =  foldlWCDigit f z vl pr vmsr+    zpm     =  foldlWCTree (foldlWCNode f) zp vlp m vsr+    zpms    =  foldlWCDigit f zpm vlpm sf vr++foldlWCNode :: (Measured v a) =>+    (b -> v -> a -> v -> b) -> b -> v -> Node v a -> v -> b+foldlWCNode f z vl (Node2 _ a b) vr = f (f z vl a vbr) vla b vr+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+foldlWCNode f z vl (Node3 _ a b c) vr =+    f (f (f z vl a vbcr) vla b vcr) vlab c vr+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr++foldlWCDigit :: (Measured v a) =>+    (b -> v -> a -> v -> b) -> b -> v -> Digit a -> v -> b+foldlWCDigit f z vl (One a) vr = f z vl a vr+foldlWCDigit f z vl (Two a b) vr = f (f z vl a vbr) vla b vr+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+foldlWCDigit f z vl (Three a b c) vr =+    f (f (f z vl a vbcr) vla b vcr) vlab c vr+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr+foldlWCDigit f z vl (Four a b c d) vr =+    f (f (f (f z vl a vbcdr) vla b vcdr) vlab c vdr) vlabc d vr+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vlabc   =  vlab `mappend` measure c+    vdr     =  measure d `mappend` vr+    vcdr    =  measure c `mappend` vdr+    vbcdr   =  measure b `mappend` vcdr++-- | Fold the tree from the right with a function that also takes the+-- measure of the prefix to the left of the element and the measure of+-- the suffix to the right of the element.+--+-- @since 0.1.5.0+foldrWithContext :: (Measured v a) =>+    (v -> a -> v -> b -> b) -> b -> FingerTree v a -> b+foldrWithContext f z t = foldrWCTree f z mempty t mempty++foldrWCTree :: (Measured v a) =>+    (v -> a -> v -> b -> b) -> b -> v -> FingerTree v a -> v -> b+foldrWCTree _ z _ Empty _ = z+foldrWCTree f z vl (Single x) vr = f vl x vr z+foldrWCTree f z vl (Deep _ pr m sf) vr = zpms+  where+    vlp     =  vl `mappend` measure pr+    vlpm    =  vlp `mappend` vm+    vmsr    =  vm `mappend` vsr+    vsr     =  measure sf `mappend` vr+    vm      =  measure m+    zpms    =  foldrWCDigit f zms vl pr vmsr+    zms     =  foldrWCTree (foldrWCNode f) zs vlp m vsr+    zs      =  foldrWCDigit f z vlpm sf vr++-- different argument order for convenience+foldrWCNode :: (Measured v a) =>+    (v -> a -> v -> b -> b) -> v -> Node v a -> v -> b -> b+foldrWCNode f vl (Node2 _ a b) vr z = f vl a vbr (f vla b vr z)+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+foldrWCNode f vl (Node3 _ a b c) vr z =+    f vl a vbcr (f vla b vcr (f vlab c vr z))+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr++foldrWCDigit :: (Measured v a) =>+    (v -> a -> v -> b -> b) -> b -> v -> Digit a -> v -> b+foldrWCDigit f z vl (One a) vr = f vl a vr z+foldrWCDigit f z vl (Two a b) vr = f vl a vbr (f vla b vr z)+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+foldrWCDigit f z vl (Three a b c) vr =+    f vl a vbcr (f vla b vcr (f vlab c vr z))+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr+foldrWCDigit f z vl (Four a b c d) vr =+    f vl a vbcdr (f vla b vcdr (f vlab c vdr (f vlabc d vr z)))+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vlabc   =  vlab `mappend` measure c+    vdr     =  measure d `mappend` vr+    vcdr    =  measure c `mappend` vdr+    vbcdr   =  measure b `mappend` vcdr++-- | Like 'traverse', but with constraints on the element types.+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++-- | Traverse the tree from left to right with a function that also+-- takes the measure of the prefix of the tree to the left of the element.+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++-- | Traverse the tree from left to right with a function that also+-- takes the measure of the prefix to the left and the measure of the+-- suffix to the right of the element.+--+-- @since 0.1.2.0+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 vbr <*> f vla b vr+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+traverseWCNode f vl (Node3 _ a b c) vr =+    node3 <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr++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 vbr <*> f vla b vr+  where+    vla     =  vl `mappend` measure a+    vbr     =  measure b `mappend` vr+traverseWCDigit f vl (Three a b c) vr =+    Three <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vcr     =  measure c `mappend` vr+    vbcr    =  measure b `mappend` vcr+traverseWCDigit f vl (Four a b c d) vr =+    Four <$> f vl a vbcdr <*> f vla b vcdr <*> f vlab c vdr <*> f vlabc d vr+  where+    vla     =  vl `mappend` measure a+    vlab    =  vla `mappend` measure b+    vlabc   =  vlab `mappend` measure c+    vdr     =  measure d `mappend` vr+    vcdr    =  measure c `mappend` vdr+    vbcdr   =  measure b `mappend` vcdr++-- | Like 'traverse', but safe only if the function preserves the measure.+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++-----------------------------------------------------+-- 4.3 Construction, deconstruction and concatenation+-----------------------------------------------------++-- | /O(1)/. The empty sequence.+empty :: Measured v a => FingerTree v a+empty = Empty++-- | /O(1)/. A singleton sequence.+singleton :: Measured v a => a -> FingerTree v a+singleton = Single++-- | /O(n)/. Create a sequence from a finite list of elements.+-- The opposite operation 'toList' is supplied by the 'Foldable' instance.+fromList :: (Measured v a) => [a] -> FingerTree v a+fromList = foldr (<|) Empty++-- | /O(1)/. Add an element to the left end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(<|) :: (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"++-- | /O(1)/. Add an element to the right end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(|>) :: (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"++-- | /O(1)/. Is this the empty sequence?+null :: FingerTree v a -> Bool+null Empty = True+null _ = False++-- | /O(1)/. Analyse the left end of a sequence.+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++-- | /O(1)/. Analyse the right end of a sequence.+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)++----------------+-- Concatenation+----------------++-- | /O(log(min(n1,n2)))/. Concatenate two sequences.+(><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a+(><) =  appendTree0++-- appendTree<0..4> and addDigits<0..4> were generated by misc/mkappend.hs++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++----------------+-- 4.4 Splitting+----------------++-- | A result of 'search', attempting to find a point where a predicate+-- on splits of the sequence changes from 'False' to 'True'.+--+-- @since 0.1.2.0+data SearchResult v a+    = Position !(FingerTree v a) a !(FingerTree v a)+        -- ^ A tree opened at a particular element: the prefix to the+        -- left, the element, and the suffix to the right.+    | OnLeft+        -- ^ A position to the left of the sequence, indicating that the+        -- predicate is 'True' at both ends.+    | OnRight+        -- ^ A position to the right of the sequence, indicating that the+        -- predicate is 'False' at both ends.+    | Nowhere+        -- ^ No position in the tree, returned if the predicate is 'True'+        -- at the left end and 'False' at the right end.  This will not+        -- occur if the predicate in monotonic on the tree.+    deriving (Eq, Ord, Show+#if __GLASGOW_HASKELL__ >= 706+        , Generic+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#endif+        )++-- | /O(log(min(i,n-i)))/. Search a sequence for a point where a predicate+-- on splits of the sequence changes from 'False' to 'True'.+--+-- The argument @p@ is a relation between the measures of the two+-- sequences that could be appended together to form the sequence @t@.+-- If the relation is 'False' at the leftmost split and 'True' at the+-- rightmost split, i.e.+--+-- @not (p 'mempty' ('measure' t)) && p ('measure' t) 'mempty'@+--+-- then there must exist an element @x@ in the sequence such that @p@+-- is 'False' for the split immediately before @x@ and 'True' for the+-- split just after it:+--+-- <<images/search.svg>>+--+-- In this situation, @'search' p t@ returns such an element @x@ and the+-- pieces @l@ and @r@ of the sequence to its left and right respectively.+-- That is, it returns @'Position' l x r@ such that+--+-- * @l >< (x <| r) = t@+--+-- * @not (p (measure l) (measure (x <| r))@+--+-- * @p (measure (l |> x)) (measure r)@+--+-- For predictable results, one should ensure that there is only one such+-- point, i.e. that the predicate is /monotonic/ on @t@.+--+-- @since 0.1.2.0+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++-- isSplit :: (Measured v a) => (v -> v -> Bool) -> v -> a -> v -> Bool+-- isSplit p vl x vr = not (p vl (v `mappend` vr)) && p (vl `mappend` v) vr+--   where v = measure x+--+-- property:+-- isSplit p vl t vr =>+--    let Split l x r = search t in+--    isSplit p (vl `mappend` measure l) x (measure r `mappend` vr)++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 = case searchDigit p vl pr vmsr of+    Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)+  | p vlpm vsr = case searchTree p vlp m vsr of+    Split ml xs mr -> case searchNode p (vlp `mappend` measure ml) xs (measure mr `mappend` vsr) of+        Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)+  | otherwise = case searchDigit p vlpm sf vr of+    Split l x r -> 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++-- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate+-- on the accumulated measure of the prefix changes from 'False' to 'True'.+--+-- For predictable results, one should ensure that there is only one such+-- point, i.e. that the predicate is /monotonic/.+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++-- | /O(log(min(i,n-i)))/.+-- Given a monotonic predicate @p@, @'takeUntil' p t@ is the largest+-- prefix of @t@ whose measure does not satisfy @p@.+--+-- *  @'takeUntil' p t = 'fst' ('split' p t)@+takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a+takeUntil p  =  fst . split p++-- | /O(log(min(i,n-i)))/.+-- Given a monotonic predicate @p@, @'dropUntil' p t@ is the rest of @t@+-- after removing the largest prefix whose measure does not satisfy @p@.+--+-- * @'dropUntil' p t = 'snd' ('split' p t)@+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 = case splitDigit p i pr of+    Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)+  | p vm = case splitTree p vpr m of+    Split ml xs mr -> case splitNode p (vpr `mappend` measure ml) xs of+        Split l x r -> Split (deepR pr  ml l) x (deepL r mr sf)+  | otherwise = case splitDigit p vm sf of+    Split l x r -> 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++------------------+-- Transformations+------------------++-- | /O(n)/. The reverse of a sequence.+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"++{- $example++Particular abstract data types may be implemented by defining+element types with suitable 'Measured' instances.++(from section 4.5 of the paper)+Simple sequences can be implemented using a 'Data.Monoid.Sum' monoid+as a measure:  > newtype Elem a = Elem { getElem :: a } >
Data/IntervalMap/FingerTree.hs view
@@ -1,20 +1,33 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE DeriveAnyClass #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.PriorityQueue.FingerTree -- Copyright   :  (c) Ross Paterson 2008 -- License     :  BSD-style--- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  non-portable (MPTCs and functional dependencies) -- -- Interval maps implemented using the 'FingerTree' type, following -- section 4.8 of -----    * Ralf Hinze and Ross Paterson,---      \"Finger trees: a simple general-purpose data structure\",---      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.---      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--  * Ralf Hinze and Ross Paterson,+--    \"Finger trees: a simple general-purpose data structure\",+--    /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+--    <https://staff.city.ac.uk/~ross/papers/FingerTree.html> -- -- An amortized running time is given for each operation, with /n/ -- referring to the size of the priority queue.  These bounds hold even@@ -27,76 +40,171 @@ -----------------------------------------------------------------------------  module Data.IntervalMap.FingerTree (-	-- * Intervals-	Interval(..), point,-	-- * Interval maps-	IntervalMap, empty, singleton, insert, union,-	-- * Searching-	search, intersections, dominators-	) where+    -- * Intervals+    Interval(..), low, high, point,+    -- * Interval maps+    IntervalMap, empty, singleton, insert, union,+    -- * Searching+    search, intersections, dominators,+    -- * Extraction+    bounds, leastView, splitAfter+    ) where  import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) +import Prelude hiding (null)+#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 ((<$>))-import Data.Traversable (Traversable(traverse))-import Data.Foldable (Foldable(foldMap)) import Data.Monoid+#endif+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))+#endif+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Control.DeepSeq+import Data.Foldable (toList)  ---------------------------------- -- 4.8 Application: interval trees ----------------------------------  -- | A closed interval.  The lower bound should be less than or equal--- to the higher bound.-data Interval v = Interval { low :: v, high :: v }-	deriving (Eq, Ord, Show)+-- to the upper bound.+data Interval v = Interval v v -- ^ Lower and upper bounds of the interval.+    deriving (Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 706+        , Generic+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#endif+        ) +-- | Lower bound of the interval+low :: Interval v -> v+low (Interval lo _) = lo++-- | Upper bound of the interval+high :: Interval v -> v+high (Interval _ hi) = hi+ -- | An interval in which the lower and upper bounds are equal. point :: v -> Interval v point v = Interval v v  data Node v a = Node (Interval v) a+    deriving (Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 706+        , Generic+#if __GLASGOW_HASKELL__ >= 710+        , NFData+#endif+#endif+        )  instance Functor (Node v) where-	fmap f (Node i x) = Node i (f x)+    fmap f (Node i x) = Node i (f x)  instance Foldable (Node v) where-	foldMap f (Node _ x) = f x+    foldMap f (Node _ x) = f x  instance Traversable (Node v) where-	traverse f (Node i x) = Node i <$> f x+    traverse f (Node i x) = Node i <$> f x  -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706+    deriving (Generic)+#endif +#if MIN_VERSION_base(4,9,0)+instance Ord v => Semigroup (IntInterval v) where+    (<>) = intervalUnion+#endif+ instance Ord v => Monoid (IntInterval v) where-	mempty = NoInterval-	NoInterval `mappend` i	= i-	i `mappend` NoInterval	= i-	IntInterval _ hi1 `mappend` IntInterval int2 hi2 =-		IntInterval int2 (max hi1 hi2)+    mempty = NoInterval+#if !(MIN_VERSION_base(4,11,0))+    mappend = intervalUnion+#endif +intervalUnion :: Ord v => IntInterval v -> IntInterval v -> IntInterval v+NoInterval `intervalUnion` i  = i+i `intervalUnion` NoInterval  = i+IntInterval _ hi1 `intervalUnion` IntInterval int2 hi2 =+    IntInterval int2 (max hi1 hi2)+ instance (Ord v) => Measured (IntInterval v) (Node v a) where-	measure (Node i _) = IntInterval i (high i)+    measure (Node i _) = IntInterval i (high i)  -- | Map of closed intervals, possibly with duplicates.--- The 'Foldable' and 'Traversable' instances process the intervals in--- lexicographical order. newtype IntervalMap v a =-	IntervalMap (FingerTree (IntInterval v) (Node v a))+    IntervalMap (FingerTree (IntInterval v) (Node v a))+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706+    deriving (Generic)+#endif -- ordered lexicographically by interval  instance Functor (IntervalMap v) where-	fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t)+    fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) +-- | Values in lexicographical order of intervals. instance Foldable (IntervalMap v) where-	foldMap f (IntervalMap t) = foldMap (foldMap f) t+    foldMap f (IntervalMap t) = foldMap (foldMap f) t+#if MIN_VERSION_base(4,8,0)+    null (IntervalMap t) = FT.null t+#endif +-- | Traverse the intervals in lexicographical order. instance Traversable (IntervalMap v) where-	traverse f (IntervalMap t) =-		IntervalMap <$> FT.unsafeTraverse (traverse f) t+    traverse f (IntervalMap t) =+        IntervalMap <$> FT.unsafeTraverse (traverse f) t +instance (Eq v, Eq a) => Eq (IntervalMap v a) where+    IntervalMap xs == IntervalMap ys = toList xs == toList ys++-- | Lexicographical ordering+instance (Ord v, Ord a) => Ord (IntervalMap v a) where+    compare (IntervalMap xs) (IntervalMap ys) = compare (toList xs) (toList ys)++instance (Show v, Show a) => Show (IntervalMap v a) where+    showsPrec p (IntervalMap ns)+      | FT.null ns = showString "empty"+      | otherwise =+        showParen (p > 0) (showIntervals (toList ns))+      where+        showIntervals [] = showString "empty"+        showIntervals (Node i x:ixs) =+            showString "insert " . showsPrec 11 i .+                showChar ' ' . showsPrec 11 x .+                showString " $ " . showIntervals ixs++#if MIN_VERSION_base(4,9,0)+-- | 'union'.+instance (Ord v) => Semigroup (IntervalMap v a) where+    (<>) = union+#endif++-- | 'empty' and 'union'.+instance (Ord v) => Monoid (IntervalMap v a) where+    mempty = empty+#if !(MIN_VERSION_base(4,11,0))+    mappend = union+#endif+ -- | /O(1)/.  The empty interval map. empty :: (Ord v) => IntervalMap v a empty = IntervalMap FT.empty@@ -105,30 +213,37 @@ singleton :: (Ord v) => Interval v -> a -> IntervalMap v a singleton i x = IntervalMap (FT.singleton (Node i x)) --- | /O(log n)/.  Insert an interval into a map.+-- | /O(log n)/.  Insert an interval and associated value into a map. -- The map may contain duplicate intervals; the new entry will be inserted -- before any existing entries for the same interval. insert :: (Ord v) => Interval v -> a -> IntervalMap v a -> IntervalMap v a-insert (Interval lo hi) x m | lo > hi = m+insert (Interval lo hi) _ m | lo > hi = m insert i x (IntervalMap t) = IntervalMap (l >< Node i x <| r)-  where (l, r) = FT.split larger t-	larger (IntInterval k _) = k >= i+  where+    (l, r) = FT.split larger t+    larger (IntInterval k _) = k >= i+    larger NoInterval = error "larger NoInterval"  -- | /O(m log (n/\//m))/.  Merge two interval maps. -- The map may contain duplicate intervals; entries with equal intervals -- are kept in the original order. union  ::  (Ord v) => IntervalMap v a -> IntervalMap v a -> IntervalMap v a union (IntervalMap xs) (IntervalMap ys) = IntervalMap (merge1 xs ys)-  where merge1 as bs = case FT.viewl as of-		EmptyL			-> bs-		a@(Node i _) :< as'	-> l >< a <| merge2 as' r-		  where (l, r) = FT.split larger bs-			larger (IntInterval k _) = k >= i-	merge2 as bs = case FT.viewl bs of-		EmptyL			-> as-		b@(Node i _) :< bs'	-> l >< b <| merge1 r bs'-		  where (l, r) = FT.split larger as-			larger (IntInterval k _) = k > i+  where+    merge1 as bs = case FT.viewl as of+        EmptyL                  -> bs+        a@(Node i _) :< as'     -> l >< a <| merge2 as' r+          where+            (l, r) = FT.split larger bs+            larger (IntInterval k _) = k >= i+            larger NoInterval = error "larger NoInterval"+    merge2 as bs = case FT.viewl bs of+        EmptyL                  -> as+        b@(Node i _) :< bs'     -> l >< b <| merge1 r bs'+          where+            (l, r) = FT.split larger as+            larger (IntInterval k _) = k > i+            larger NoInterval = error "larger NoInterval"  -- | /O(k log (n/\//k))/.  All intervals that intersect with the given -- interval, in lexicographical order.@@ -149,39 +264,81 @@ -- interval, in lexicographical order. inRange :: (Ord v) => v -> v -> IntervalMap v a -> [(Interval v, a)] inRange lo hi (IntervalMap t) = matches (FT.takeUntil (greater hi) t)-  where matches xs  =  case FT.viewl (FT.dropUntil (atleast lo) xs) of-		EmptyL    ->  []-		Node i x :< xs'  ->  (i, x) : matches xs'+  where+    matches xs  =  case FT.viewl (FT.dropUntil (atleast lo) xs) of+        EmptyL    ->  []+        Node i x :< xs'  ->  (i, x) : matches xs' +-- | /O(1)/.  @'bounds' m@ returns @'Nothing'@ if @m@ is empty, and+-- otherwise @'Just' i@, where @i@ is the smallest interval containing+-- all the intervals in the map.+--+-- @since 0.1.3.0+bounds :: (Ord v) => IntervalMap v a -> Maybe (Interval v)+bounds (IntervalMap t) = case measure t of+    NoInterval -> Nothing+    IntInterval _ hi -> case FT.viewl t of+        EmptyL -> Nothing+        Node (Interval lo _) _ FT.:< _ -> Just (Interval lo hi)++-- | /O(1)/.  @'leastView' m@ returns @'Nothing'@ if @m@ is empty, and+-- otherwise @'Just' ((i, x), m')@, where @i@ is the least interval,+-- @x@ is the associated value, and @m'@ is the rest of the map.+--+-- @since 0.1.3.0+leastView :: Ord v =>+    IntervalMap v a -> Maybe ((Interval v, a), IntervalMap v a)+leastView (IntervalMap t) = case FT.viewl t of+    EmptyL -> Nothing+    Node i a FT.:< t' -> Just ((i, a), IntervalMap t')++-- | /O(log(min(i,n-i)))/.  @'splitAfter' k m@ returns a pair of submaps,+-- one consisting of intervals whose lower bound is less than or equal+-- to @k@, and the other of those whose lower bound is greater.+--+-- @since 0.1.3.0+splitAfter :: Ord v =>+    v -> IntervalMap v a -> (IntervalMap v a, IntervalMap v a)+splitAfter k (IntervalMap t) = (IntervalMap before, IntervalMap after)+  where+    (before, after) = FT.split (greater k) t+ atleast :: (Ord v) => v -> IntInterval v -> Bool atleast k (IntInterval _ hi) = k <= hi+atleast _ NoInterval = error "atleast NoInterval"  greater :: (Ord v) => v -> IntInterval v -> Bool greater k (IntInterval i _) = low i > k+greater _ NoInterval = error "greater NoInterval" +{-+-- Examples+ mkMap :: (Ord v) => [(v, v, a)] -> IntervalMap v a mkMap = foldr ins empty-  where ins (lo, hi, n) = insert (Interval lo hi) n+  where+    ins (lo, hi, n) = insert (Interval lo hi) n  composers :: IntervalMap Int String composers = mkMap [-	(1685, 1750, "Bach"),-	(1685, 1759, "Handel"),-	(1732, 1809, "Haydn"),-	(1756, 1791, "Mozart"),-	(1770, 1827, "Beethoven"),-	(1782, 1840, "Paganini"),-	(1797, 1828, "Schubert"),-	(1803, 1869, "Berlioz"),-	(1810, 1849, "Chopin"),-	(1833, 1897, "Brahms"),-	(1838, 1875, "Bizet")]+    (1685, 1750, "Bach"),+    (1685, 1759, "Handel"),+    (1732, 1809, "Haydn"),+    (1756, 1791, "Mozart"),+    (1770, 1827, "Beethoven"),+    (1782, 1840, "Paganini"),+    (1797, 1828, "Schubert"),+    (1803, 1869, "Berlioz"),+    (1810, 1849, "Chopin"),+    (1833, 1897, "Brahms"),+    (1838, 1875, "Bizet")]  mathematicians :: IntervalMap Int String mathematicians = mkMap [-	(1642, 1727, "Newton"),-	(1646, 1716, "Leibniz"),-	(1707, 1783, "Euler"),-	(1736, 1813, "Lagrange"),-	(1777, 1855, "Gauss"),-	(1811, 1831, "Galois")]+    (1642, 1727, "Newton"),+    (1646, 1716, "Leibniz"),+    (1707, 1783, "Euler"),+    (1736, 1813, "Lagrange"),+    (1777, 1855, "Gauss"),+    (1811, 1831, "Galois")]+-}
Data/PriorityQueue/FingerTree.hs view
@@ -1,20 +1,33 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802+{-# LANGUAGE AutoDeriveTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE DeriveAnyClass #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.PriorityQueue.FingerTree -- Copyright   :  (c) Ross Paterson 2008 -- License     :  BSD-style--- Maintainer  :  ross@soi.city.ac.uk+-- Maintainer  :  R.Paterson@city.ac.uk -- Stability   :  experimental -- Portability :  non-portable (MPTCs and functional dependencies) -- -- Min-priority queues implemented using the 'FingerTree' type, -- following section 4.6 of -----    * Ralf Hinze and Ross Paterson,---      \"Finger trees: a simple general-purpose data structure\",---      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.---      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--  * Ralf Hinze and Ross Paterson,+--    \"Finger trees: a simple general-purpose data structure\",+--    /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+--    <https://staff.city.ac.uk/~ross/papers/FingerTree.html> -- -- These have the same big-O complexity as skew heap implementations, -- but are approximately an order of magnitude slower.@@ -33,66 +46,127 @@ -----------------------------------------------------------------------------  module Data.PriorityQueue.FingerTree (-	PQueue,-	-- * Construction-	empty,-	singleton,-	union,-	insert,-	add,-	fromList,-	-- * Deconstruction-	null,-	minView,-	minViewWithKey-	) where+    PQueue,+    -- * Construction+    empty,+    singleton,+    union,+    insert,+    add,+    fromList,+    -- * Deconstruction+    null,+    minView,+    minViewWithKey+    ) where  import qualified Data.FingerTree as FT-import Data.FingerTree (FingerTree, (<|), (|>), (><),-			ViewL(..), Measured(measure))+import Data.FingerTree (FingerTree, (<|), (|>), (><), ViewL(..), Measured(..)) -import Control.Arrow ((***))-import Data.Foldable (Foldable(foldMap))+import Prelude hiding (null)+#if MIN_VERSION_base(4,6,0)+import GHC.Generics+#endif+#if MIN_VERSION_base(4,8,0)+import qualified Prelude (null)+#else import Data.Monoid+#endif+#if !(MIN_VERSION_base(4,8,0)) || defined(__MHS__)+import Data.Foldable (Foldable(foldMap))+#endif+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Control.Arrow ((***))+import Control.DeepSeq import Data.List (unfoldr)-import Prelude hiding (null) -data Entry k v = Entry { key :: k, value :: v }+data Entry k v = Entry k v+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706+    deriving (Generic)+#endif  instance Functor (Entry k) where-	fmap f (Entry k v) = Entry k (f v)+    fmap f (Entry k v) = Entry k (f v)  instance Foldable (Entry k) where-	foldMap f (Entry _ v) = f v+    foldMap f (Entry _ v) = f v  data Prio k v = NoPrio | Prio k v+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706+    deriving (Generic)+#endif +#if MIN_VERSION_base(4,9,0)+instance Ord k => Semigroup (Prio k v) where+    (<>) = unionPrio+#endif+ instance Ord k => Monoid (Prio k v) where-	mempty			= NoPrio-	x `mappend` NoPrio	= x-	NoPrio `mappend` y	= y-	x@(Prio kx _) `mappend` y@(Prio ky _)-	  | kx <= ky		= x-	  | otherwise		= y+    mempty  = NoPrio+#if !(MIN_VERSION_base(4,11,0))+    mappend = unionPrio+#endif +unionPrio :: Ord k => Prio k v -> Prio k v -> Prio k v+x `unionPrio` NoPrio      = x+NoPrio `unionPrio` y      = y+x@(Prio kx _) `unionPrio` y@(Prio ky _)+  | kx <= ky            = x+  | otherwise           = y+ instance Ord k => Measured (Prio k v) (Entry k v) where-	measure (Entry k v) = Prio k v+    measure (Entry k v) = Prio k v  -- | Priority queues. newtype PQueue k v = PQueue (FingerTree (Prio k v) (Entry k v))+#if __GLASGOW_HASKELL__ >= 710+    deriving (Generic, NFData)+#elif __GLASGOW_HASKELL__ >= 706+    deriving (Generic)+#endif  instance Ord k => Functor (PQueue k) where-	fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs)+    fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs) +-- | In ascending order of keys. instance Ord k => Foldable (PQueue k) where-	foldMap f q = case minView q of-		Nothing -> mempty-		Just (v, q') -> f v `mappend` foldMap f q'+    foldMap f q = case minView q of+        Nothing -> mempty+        Just (v, q') -> f v `mappend` foldMap f q'+#if MIN_VERSION_base(4,8,0)+    null (PQueue q) = FT.null q+#endif +#if MIN_VERSION_base(4,9,0)+instance Ord k => Semigroup (PQueue k v) where+    (<>) = union+#endif++-- | 'empty' and 'union' instance Ord k => Monoid (PQueue k v) where-	mempty = empty-	mappend = union+    mempty = empty+#if !(MIN_VERSION_base(4,11,0))+    mappend = union+#endif +instance (Ord k, Eq v) => Eq (PQueue k v) where+    xs == ys = assocs xs == assocs ys++-- | Lexicographical ordering+instance (Ord k, Ord v) => Ord (PQueue k v) where+    compare xs ys = compare (assocs xs) (assocs ys)++-- | In ascending key order+instance (Ord k, Show k, Show v) => Show (PQueue k v) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (assocs xs)+ -- | /O(1)/. The empty priority queue. empty :: Ord k => PQueue k v empty = PQueue FT.empty@@ -101,7 +175,7 @@ singleton :: Ord k => k -> v -> PQueue k v singleton k v = PQueue (FT.singleton (Entry k v)) --- | /O(log n)/. Add a (priority, value) pair to the front of a priority queue.+-- | /O(1)/. Add a (priority, value) pair to the front of a priority queue. -- -- * @'insert' k v q = 'union' ('singleton' k v) q@ --@@ -136,7 +210,7 @@ null :: Ord k => PQueue k v -> Bool null (PQueue q) = FT.null q --- | /O(1)/ (/O(log(n))/ for the reduced queue).+-- | /O(1)/ for the element, /O(log(n))/ for the reduced queue. -- Returns 'Nothing' for an empty map, or the value associated with the -- minimal priority together with the rest of the priority queue. --@@ -147,7 +221,7 @@ minView :: Ord k => PQueue k v -> Maybe (v, PQueue k v) minView q = fmap (snd *** id) (minViewWithKey q) --- | /O(1)/ (/O(log(n))/ for the reduced queue).+-- | /O(1)/ for the element, /O(log(n))/ for the reduced queue. -- Returns 'Nothing' for an empty map, or the minimal (priority, value) -- pair together with the rest of the priority queue. --@@ -165,11 +239,16 @@ minViewWithKey (PQueue q)   | FT.null q = Nothing   | otherwise = Just ((k, v), case FT.viewl r of-	_ :< r' -> PQueue (l >< r')-	_ -> error "can't happen")-  where Prio k v = measure q-	(l, r) = FT.split (below k) q+    _ :< r' -> PQueue (l >< r')+    _ -> error "can't happen")+  where+    Prio k v = measure q+    (l, r) = FT.split (below k) q  below :: Ord k => k -> Prio k v -> Bool below _ NoPrio = False below k (Prio k' _) = k' <= k++-- | /O(n)/. Key-value pairs in ascending key order.+assocs :: Ord k => PQueue k v -> [(k, v)]+assocs = unfoldr minViewWithKey
+ changelog view
@@ -0,0 +1,66 @@+-*-change-log-*-++0.1.6.3 Ross Paterson <R.Paterson@city.ac.uk> Dec 2025+	* Patches for MicroHS++0.1.6.2 Ross Paterson <R.Paterson@city.ac.uk> Jul 2025+	* Change http links in docs to https++0.1.6.1 Ross Paterson <R.Paterson@city.ac.uk> May 2025+	* Added NFData instances++0.1.5.0 Ross Paterson <R.Paterson@city.ac.uk> Jan 2022+	* Added foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext (James Cranch)+	* Fixed bug in traverseWithContext+	* Made split and search stricter++0.1.4.2 Ross Paterson <R.Paterson@city.ac.uk> Dec 2018+	* Fixed bug in search++0.1.4.1 Ross Paterson <R.Paterson@city.ac.uk> Mar 2018+	* Disabled Generic instances for GHC <= 7.6++0.1.4.0 Ross Paterson <R.Paterson@city.ac.uk> Mar 2018+	* Added Generic instances++0.1.3.1 Ross Paterson <R.Paterson@city.ac.uk> Dec 2017+	* Fixed Data.IntervalMap.FingerTree.bounds++0.1.3.0 Ross Paterson <R.Paterson@city.ac.uk> Nov 2017+	* Fixed Show instance for IntervalMap+	* Added bounds, leastView and splitAfter to IntervalMap++0.1.2.1 Ross Paterson <R.Paterson@city.ac.uk> Oct 2017+	* Fix for GHC <= 7.8++0.1.2.0 Ross Paterson <R.Paterson@city.ac.uk> Oct 2017+	* Removed constraint on the type of null+	* Added versions of fmap and traverse passing the measures of both sides+	* Added new search function, a symmetrical generalization of split+	* Added Eq, Ord and Show instances for IntervalMap and PriorityQueue+	* Made low and high into separate functions+	* Updated for Monoid, Foldable, Traversable in Prelude+	* Made compatible with Semigroup/Monoid proposal++0.1.1.0 Ross Paterson <R.Paterson@city.ac.uk> Jun 2015+	* Added Safe for GHC >= 7.2+	* Added AutoDeriveTypeable for GHC >= 7.10++0.1.0.2 Ross Paterson <ross@soi.city.ac.uk> Mar 2015+	* Cabal file updates++0.1.0.1 Ross Paterson <ross@soi.city.ac.uk> Feb 2015+	* fix warnings++0.1.0.0 Ross Paterson <ross@soi.city.ac.uk> Jun 2013+	* Added Monoid instance for IntervalMap+	* Removed unnecessary Measured v a constraints on Eq, Ord, and Show instances++0.0.1.1 Ross Paterson <ross@soi.city.ac.uk> Sep 2012+	* Cabal file updates++0.0.1.0 Ross Paterson <ross@soi.city.ac.uk> Jul 2009+	* Added Data.IntervalMap.FingerTree and Data.PriorityQueue.FingerTree++0.0 Ross Paterson <ross@soi.city.ac.uk> May 2007+	* Initial revision
fingertree.cabal view
@@ -1,10 +1,11 @@ Name:           fingertree-Version:        0.0.1.1-Cabal-Version:  >= 1.6+Version:        0.1.6.3+Cabal-Version:  1.18 Copyright:      (c) 2006 Ross Paterson, Ralf Hinze License:        BSD3 License-File:   LICENSE-Maintainer:     Ross Paterson <ross@soi.city.ac.uk>+Maintainer:     Ross Paterson <R.Paterson@city.ac.uk>+bug-reports:    https://hub.darcs.net/ross/fingertree/issues Category:       Data Structures Synopsis:       Generic finger-tree structure, with example instances Description:@@ -16,20 +17,27 @@                  * Ralf Hinze and Ross Paterson,                    \"Finger trees: a simple general-purpose data structure\",                    /Journal of Functional Programming/ 16:2 (2006) pp 197-217.-                   <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+                   <https://staff.city.ac.uk/~ross/papers/FingerTree.html>                 .                 For a tuned sequence type, see @Data.Sequence@ in the                 @containers@ package, which is a specialization of                 this structure. Build-Type:     Simple+Extra-Doc-Files:+                changelog+                images/search.svg  Source-Repository head   Type: darcs-  Location: http://code.haskell.org/~ross/fingertree+  Location: https://hub.darcs.net/ross/fingertree  Library-  Build-Depends: base < 6-  Extensions:   MultiParamTypeClasses+  Build-Depends:+                base < 6,+                deepseq >= 1.3 && < 1.6+  Default-Language: Haskell2010+  Other-Extensions:+                MultiParamTypeClasses                 FunctionalDependencies                 FlexibleInstances                 UndecidableInstances@@ -37,3 +45,17 @@                 Data.FingerTree                 Data.IntervalMap.FingerTree                 Data.PriorityQueue.FingerTree++Test-suite ft-properties+  type: exitcode-stdio-1.0+  main-is: tests/ft-properties.hs+  cpp-options: -DTESTING+  default-language: Haskell2010+  build-depends:+                base >= 4.2 && < 6,+                deepseq >= 1.3 && < 1.6,+                HUnit,+                QuickCheck,+                test-framework,+                test-framework-hunit,+                test-framework-quickcheck2
+ images/search.svg view
@@ -0,0 +1,53 @@+<?xml version="1.0" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+  "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg width="700" height="200" xmlns="http://www.w3.org/2000/svg" version="1.1">+<g transform="translate(25,90)">+ <g stroke="black" stroke-width="1" fill="#fda">+  <rect x="0" y="0" height="50" width="600" />+  <line x1="300" y1="0" x2="300" y2="50" />+  <line x1="340" y1="0" x2="340" y2="50" />+ </g>+ <g transform="translate(0,-15)">+  <g stroke="black" stroke-width="0.5" fill="none">+   <line x1="0" y1="0" x2="600" y2="0" />+   <line x1="0" y1="-12" x2="0" y2="12" />+   <line x1="300" y1="-12" x2="300" y2="12" />+   <line x1="600" y1="-12" x2="600" y2="12" />+   <polyline points="9,-8 1,0 9,8" />+   <polyline points="291,-8 299,0 291,8" />+   <polyline points="309,-8 301,0 309,8" />+   <polyline points="591,-8 599,0 591,8" />+  </g>+ </g>+ <g transform="translate(0,65)">+  <g stroke="black" stroke-width="0.5" fill="none">+   <line x1="0" y1="0" x2="600" y2="0" />+   <line x1="0" y1="-12" x2="0" y2="12" />+   <line x1="340" y1="-12" x2="340" y2="12" />+   <line x1="600" y1="-12" x2="600" y2="12" />+   <polyline points="9,-8 1,0 9,8" />+   <polyline points="331,-8 339,0 331,8" />+   <polyline points="349,-8 341,0 349,8" />+   <polyline points="591,-8 599,0 591,8" />+  </g>+ </g>+ <g>+  <text x="150" y="30" text-anchor="middle">l</text>+  <text x="320" y="30" text-anchor="middle">x</text>+  <text x="470" y="30" text-anchor="middle">r</text>+  <text x="150" y="-30" text-anchor="middle">measure l</text>+  <text x="450" y="-30" text-anchor="middle">measure (x &lt;| r)</text>+  <text x="170" y="90" text-anchor="middle">measure (l |&gt; x)</text>+  <text x="470" y="90" text-anchor="middle">measure r</text>+ </g>+ <g fill="#00f" transform="translate(640,0)">+  <g stroke="#00f" stroke-width="1">+   <line x1="-20" y1="-60" x2="20" y2="-60" />+  </g>+  <text x="0" y="-70" text-anchor="middle">p</text>+  <text x="0" y="-30" text-anchor="middle">False</text>+  <text x="0" y="90" text-anchor="middle">True</text>+ </g>+</g>+</svg>
+ tests/ft-properties.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- QuickCheck properties for Data.FingerTree++module Main where++import Data.FingerTree    -- needs to be compiled with -DTESTING for use here++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit (Assertion, (@?=))+import Test.QuickCheck hiding ((><))+import Test.QuickCheck.Poly++import Prelude hiding (null, reverse, foldl, foldl1, foldr, foldr1, all)+import qualified Prelude++import Control.Applicative (Applicative(..))+import Control.Monad (ap)+import Data.Foldable (Foldable(foldMap, foldl, foldr), toList, all)+import Data.Functor ((<$>))+import Data.Traversable (traverse)+import Data.List (inits)+import Data.Maybe (listToMaybe)+import Data.Monoid (Monoid(..))++main :: IO ()+main = defaultMainWithOpts+    [ testProperty "foldr" prop_foldr+    , testProperty "foldl" prop_foldl+    , testProperty "(==)" prop_equals+    , testProperty "compare" prop_compare+    , testProperty "mappend" prop_mappend+    , testCase "empty" test_empty+    , testProperty "singleton" prop_singleton+    , testProperty "(<|)" prop_cons+    , testProperty "(|>)" prop_snoc+    , testProperty "(><)" prop_append+    , testProperty "fromList" prop_fromList+    , testProperty "null" prop_null+    , testProperty "viewl" prop_viewl+    , testProperty "viewr" prop_viewr+    , testCase "search" test_search+    , testProperty "search" prop_search+    , testProperty "split" prop_split+    , testProperty "takeUntil" prop_takeUntil+    , testProperty "dropUntil" prop_dropUntil+    , testProperty "reverse" prop_reverse+    , testProperty "fmap'" prop_fmap'+    , testProperty "fmapWithPos" prop_fmapWithPos+    , testProperty "fmapWithContext" prop_fmapWithContext+    , testProperty "foldlWithPos" prop_foldlWithPos+    , testProperty "foldlWithContext" prop_foldlWithContext+    , testProperty "foldrWithPos" prop_foldrWithPos+    , testProperty "foldrWithContext" prop_foldrWithContext+    , testProperty "traverse'" prop_traverse'+    , testProperty "traverseWithPos" prop_traverseWithPos+    , testProperty "traverseWithContext" prop_traverseWithContext+    ] runner_opts+  where+    runner_opts = mempty { ropt_test_options = Just test_opts }+    test_opts = mempty {+          topt_maximum_generated_tests = Just 500+        , topt_maximum_unsuitable_generated_tests = Just 500+        }++{--------------------------------------------------------------------+  The general plan is to compare each function with a list equivalent.+  Each operation should produce a valid tree representing the same+  sequence as produced by its list counterpart on corresponding inputs.+  (The list versions are often lazier, but these properties ignore+  strictness.)+--------------------------------------------------------------------}++-- utilities for partial conversions++infix 4 ~=++(~=) :: (Eq a, Eq v, Measured v a, Valid a) => FingerTree v a -> [a] -> Bool+s ~= xs = valid s && toList s == xs++-- Partial conversion of an output sequence to a list.+toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]+toList' xs+  | valid xs = Just (toList xs)+  | otherwise = Nothing++-- instances++prop_foldr :: Seq A -> Bool+prop_foldr xs =+    foldr f z xs == Prelude.foldr f z (toList xs)+  where+    f = (:)+    z = []++prop_foldl :: Seq A -> Bool+prop_foldl xs =+    foldl f z xs == Prelude.foldl f z (toList xs)+  where+    f = flip (:)+    z = []++prop_equals :: Seq OrdA -> Seq OrdA -> Bool+prop_equals xs ys =+    (xs == ys) == (toList xs == toList ys)++prop_compare :: Seq OrdA -> Seq OrdA -> Bool+prop_compare xs ys =+    compare xs ys == compare (toList xs) (toList ys)++prop_mappend :: Seq A -> Seq A -> Bool+prop_mappend xs ys =+    mappend xs ys ~= toList xs ++ toList ys++-- * Construction++test_empty :: Assertion+test_empty =+    toList' (empty :: Seq A) @?= Just []++prop_singleton :: A -> Bool+prop_singleton x =+    singleton x ~= [x]++prop_cons :: A -> Seq A -> Bool+prop_cons x xs =+    x <| xs ~= x : toList xs++prop_snoc :: Seq A -> A -> Bool+prop_snoc xs x =+    xs |> x ~= toList xs ++ [x]++prop_append :: Seq A -> Seq A -> Bool+prop_append xs ys =+    xs >< ys ~= toList xs ++ toList ys++prop_fromList :: [A] -> Bool+prop_fromList xs =+    fromList xs ~= xs++-- * Deconstruction++prop_null :: Seq A -> Bool+prop_null xs =+    null xs == Prelude.null (toList xs)++-- ** Examining the ends++prop_viewl :: Seq A -> Bool+prop_viewl xs =+    case viewl xs of+    EmptyL ->   Prelude.null (toList xs)+    x :< xs' -> valid xs' && toList xs == x : toList xs'++prop_viewr :: Seq A -> Bool+prop_viewr xs =+    case viewr xs of+    EmptyR ->   Prelude.null (toList xs)+    xs' :> x -> valid xs' && toList xs == toList xs' ++ [x]++-- ** Search++prop_search :: Int -> Seq A -> Bool+prop_search n xs =+    case search p xs of+        Position _ b _ -> Just b == indexFromEnd n (toList xs)+        OnLeft         -> n >= len || null xs+        OnRight        -> n < 0+        Nowhere        -> error "impossible: the predicate is monotonic"+  where+    p vl vr = Prelude.length vl >= len - n && Prelude.length vr <= n++    len = length xs++    indexFromEnd :: Int -> [a] -> Maybe a+    indexFromEnd i = listToMaybe . drop i . Prelude.reverse++test_search :: Assertion+test_search = do+    lookupByIndexFromEnd xs1 1 @?= Just (A 4)+    lookupByIndexFromEnd xs2 1 @?= Just (A 4)+  where+    xs1 = Deep (map A [1..5]) (Four (A 1) (A 2) (A 3) (A 4)) Empty (One (A 5))+    xs2 = Deep (map A [1..5]) (One (A 1)) Empty (Four (A 2) (A 3) (A 4) (A 5))+    lookupByIndexFromEnd xs n =+        let len = length xs+            p vl vr = Prelude.length vl >= len - n && Prelude.length vr <= n+        in case search p xs of+               Position _ x _ -> Just x+               _              -> Nothing++-- ** Splitting++prop_split :: Int -> Seq A -> Bool+prop_split n xs =+    s_front ~= l_front && s_back ~= l_back+  where+    p ys = Prelude.length ys > n+    (s_front, s_back) = split p xs+    (l_front, l_back) = Prelude.splitAt n (toList xs)++prop_takeUntil :: Int -> Seq A -> Bool+prop_takeUntil n xs =+    takeUntil p xs ~= Prelude.take n (toList xs)+  where+    p ys = Prelude.length ys > n++prop_dropUntil :: Int -> Seq A -> Bool+prop_dropUntil n xs =+    dropUntil p xs ~= Prelude.drop n (toList xs)+  where+    p ys = Prelude.length ys > n++-- * Transformation++prop_reverse :: Seq A -> Bool+prop_reverse xs =+    reverse xs ~= Prelude.reverse (toList xs)++-- ** Maps++prop_fmap' :: Seq A -> Bool+prop_fmap' xs =+    fmap' f xs ~= map f (toList xs)+  where+    f = Just++prop_fmapWithPos :: FingerTree MA VA -> Bool+prop_fmapWithPos xs =+    fmapWithPos f xs ~= zipWith f (prefixes xs_list) xs_list+  where+    f = WithPos+    xs_list = toList xs++prop_fmapWithContext :: FingerTree MA VA -> Bool+prop_fmapWithContext xs =+    fmapWithContext f xs ~= zipWith3 f (prefixes xs_list) xs_list (suffixes xs_list)+  where+    f = WithContext+    xs_list = toList xs++-- ** Folds++prop_foldlWithPos :: FingerTree MA VA -> Bool+prop_foldlWithPos xs =+    foldlWithPos f z xs == foldl uncurry_f z (zip (prefixes xs_list) xs_list)+  where+    z = []+    f vxs v x = WithPos v x:vxs+    uncurry_f vxs (v, x) = f vxs v x+    xs_list = toList xs++prop_foldlWithContext :: FingerTree MA VA -> Bool+prop_foldlWithContext xs =+    foldlWithContext f z xs == foldl uncurry_f z (zip3 (prefixes xs_list) xs_list (suffixes xs_list))+  where+    z = []+    f vxs vl x vr = WithContext vl x vr:vxs+    uncurry_f vxs (vl, x, vr) = f vxs vl x vr+    xs_list = toList xs++prop_foldrWithPos :: FingerTree MA VA -> Bool+prop_foldrWithPos xs =+    foldrWithPos f z xs == foldr uncurry_f z (zip (prefixes xs_list) xs_list)+  where+    z = []+    f v x vxs = WithPos v x:vxs+    uncurry_f (v, x) vxs = f v x vxs+    xs_list = toList xs++prop_foldrWithContext :: FingerTree MA VA -> Bool+prop_foldrWithContext xs =+    foldrWithContext f z xs == foldr uncurry_f z (zip3 (prefixes xs_list) xs_list (suffixes xs_list))+  where+    z = []+    f vl x vr vxs = WithContext vl x vr:vxs+    uncurry_f (vl, x, vr) vxs = f vl x vr vxs+    xs_list = toList xs++-- ** Traversals++prop_traverse' :: Seq A -> Bool+prop_traverse' xs =+    evalM (traverse' f xs) ~= evalM (traverse f (toList xs))+  where+    f x = do+        n <- step+        return (n, x)++prop_traverseWithPos :: FingerTree MA VA -> Bool+prop_traverseWithPos xs =+    evalM (traverseWithPos f xs) ~= evalM (traverse (uncurry f) (zip (prefixes xs_list) xs_list))+  where+    f v y = do+        n <- step+        return (WithPos v (n, y))+    xs_list = toList xs++prop_traverseWithContext :: FingerTree MA VA -> Bool+prop_traverseWithContext xs =+    evalM (traverseWithContext f xs) ~= evalM (traverse uncurry_f (zip3 (prefixes xs_list) xs_list (suffixes xs_list)))+  where+    uncurry_f (vl, y, vr) = f vl y vr+    f vl y vr = do+        n <- step+        return (WithContext vl (n, y) vr)+    xs_list = toList xs++-- measure to the left of each value+prefixes :: (Measured v a) => [a] -> [v]+prefixes = scanl (<>) mempty . map measure++-- measure to the right of each value+suffixes :: (Measured v a) => [a] -> [v]+suffixes = tail . scanr (<>) mempty . map measure++------------------------------------------------------------------------+-- QuickCheck+------------------------------------------------------------------------++instance (Arbitrary a, Measured v a) => Arbitrary (FingerTree v a) where+    arbitrary = sized arb+      where+        arb :: (Arbitrary a, Measured v a) => Int -> Gen (FingerTree v a)+        arb 0 = return Empty+        arb 1 = Single <$> arbitrary+        arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary++    shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]+    shrink (Deep _ pr m sf) =+        [deep pr' m sf | pr' <- shrink pr] +++        [deep pr m' sf | m' <- shrink m] +++        [deep pr m sf' | sf' <- shrink sf]+    shrink (Single x) = map Single (shrink x)+    shrink Empty = []++instance (Arbitrary a, Measured v a) => Arbitrary (Node v a) where+    arbitrary = oneof [+        node2 <$> arbitrary <*> arbitrary,+        node3 <$> arbitrary <*> arbitrary <*> arbitrary]++    shrink (Node2 _ a b) =+        [node2 a' b | a' <- shrink a] +++        [node2 a b' | b' <- shrink b]+    shrink (Node3 _ a b c) =+        [node2 a b, node2 a c, node2 b c] +++        [node3 a' b c | a' <- shrink a] +++        [node3 a b' c | b' <- shrink b] +++        [node3 a b c' | c' <- shrink c]++instance Arbitrary a => Arbitrary (Digit a) where+    arbitrary = oneof [+        One <$> arbitrary,+        Two <$> arbitrary <*> arbitrary,+        Three <$> arbitrary <*> arbitrary <*> arbitrary,+        Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]++    shrink (One a) = map One (shrink a)+    shrink (Two a b) = [One a, One b]+    shrink (Three a b c) = [Two a b, Two a c, Two b c]+    shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]++------------------------------------------------------------------------+-- Valid trees+------------------------------------------------------------------------++class Valid a where+    valid :: a -> Bool++instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where+    valid Empty = True+    valid (Single x) = valid x+    valid (Deep s pr m sf) =+        s == measure pr `mappend` measure m `mappend` measure sf &&+        valid pr && valid m && valid sf++instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where+    valid node = measure node == foldMap measure node && all valid node++instance Valid a => Valid (Digit a) where+    valid = all valid++instance Valid A where+    valid = const True++instance Valid (a,b) where+    valid = const True++instance Valid (a,b,c) where+    valid = const True++instance Valid (Maybe a) where+    valid = const True++instance Valid [a] where+    valid = const True++------------------------------------------------------------------------+-- Use list of elements as the measure+------------------------------------------------------------------------++type Seq a = FingerTree [a] a++instance Measured [A] A where+    measure x = [x]++instance Measured [OrdA] OrdA where+    measure x = [x]++instance Measured [Maybe a] (Maybe a) where+    measure x = [x]++instance Measured [(a, b)] (a, b) where+    measure x = [x]++------------------------------------------------------------------------+-- A noncommutative monoid as a measure: semidirect product+------------------------------------------------------------------------++data MA = MA Int Int+    deriving (Eq, Show)++instance Semigroup MA where+    MA a x <> MA b y = MA (a*b) (x + a*y)++instance Monoid MA where+    mempty = MA 1 0++instance Valid MA where+    valid = const True++newtype VA = VA Int+    deriving (Eq, Show)++instance Measured MA VA where+    measure (VA x) = MA 3 x++instance Arbitrary VA where+    arbitrary = VA <$> arbitrary+    shrink (VA x) = map VA (shrink x)++instance Valid VA where+    valid = const True++------------------------------------------------------------------------+-- Values with positions and contexts+------------------------------------------------------------------------++data WithPos v a = WithPos v a+    deriving (Eq, Show)++instance Monoid v => Measured v (WithPos v a) where+    measure (WithPos v _) = v++instance (Valid v, Valid a) => Valid (WithPos v a) where+    valid (WithPos v x) = valid v && valid x++data WithContext v a = WithContext v a v+    deriving (Eq, Show)++instance Monoid v => Measured v (WithContext v a) where+    measure (WithContext vl _ vr) = vl++instance (Valid v, Valid a) => Valid (WithContext v a) where+    valid (WithContext vl x vr) = valid vl && valid x && valid vr++------------------------------------------------------------------------+-- Simple counting monad+------------------------------------------------------------------------++newtype M a = M (Int -> (Int, a))++runM :: M a -> Int -> (Int, a)+runM (M m) = m++evalM :: M a -> a+evalM m = snd (runM m 0)++instance Monad M where+    return = pure+    M u >>= f = M $ \ m -> let (n, x) = u m in runM (f x) n++instance Functor M where+    fmap f (M u) = M $ \ m -> let (n, x) = u m in (n, f x)++instance Applicative M where+    pure x = M $ \ n -> (n, x)+    (<*>) = ap++step :: M Int+step = M $ \ n -> (n+1, n)