hw-fingertree 0.1.0.0 → 0.1.0.1

raw patch · 11 files changed

+1641/−1648 lines, 11 filesdep +hedgehogdep +hspecdep +hw-fingertreePVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: hedgehog, hspec, hw-fingertree, hw-hspec-hedgehog

API changes (from Hackage documentation)

Files

• HaskellWorks/Data/FingerTree.hs +0/−870
• HaskellWorks/Data/IntervalMap/FingerTree.hs +0/−220
• HaskellWorks/Data/PriorityQueue/FingerTree.hs +0/−181
• hw-fingertree.cabal +65/−40
• src/HaskellWorks/Data/FingerTree.hs +878/−0
• src/HaskellWorks/Data/IntervalMap/FingerTree.hs +235/−0
• src/HaskellWorks/Data/PriorityQueue/FingerTree.hs +196/−0
• tests/HaskellWorks/Data/FingerTree/Gen.hs +55/−0
• tests/HaskellWorks/Data/FingerTreeSpec.hs +211/−0
• tests/Spec.hs +1/−0
• tests/ft-properties.hs +0/−337

@@ -1,870 +0,0 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DeriveAnyClass         #-}-{-# LANGUAGE DeriveGeneric          #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE UndecidableInstances   #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe                   #-}-#endif-#if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE AutoDeriveTypeable     #-}-#endif--------------------------------------------------------------------------------- |--- Module      :  Data.FingerTree--- Copyright   :  (c) Ross Paterson, Ralf Hinze 2006--- 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.---    <http://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 HaskellWorks.Data.FingerTree (-#if TESTING-    FingerTree(..), Digit(..), Node(..), deep, node2, node3,-#else-    FingerTree,-#endif-    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           Control.DeepSeq-import           Data.Foldable       (Foldable (foldMap), toList)-import           Data.Monoid-import           GHC.Generics        (Generic)--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, Generic, NFData)---- | 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, Generic, NFData)--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---- | 'empty' and '><'.-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, Generic, NFData)--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, Generic, NFData)--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)-    deriving (-#if TESTING-    Show,-#endif-    Generic, NFData)--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---- | /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--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 Eq a => Eq (FingerTree v a) where-    xs == ys = toList xs == toList ys--instance Ord a => Ord (FingerTree v a) where-    compare xs ys = compare (toList xs) (toList ys)--#if !TESTING-instance Show a => Show (FingerTree v a) where-    showsPrec p xs = showParen (p > 10) $-        showString "fromList " . shows (toList xs)-#endif---- | 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-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 :: (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 (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 `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 (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--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 _ 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       =  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 _ 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 'Sum' monoid as a measure:--> newtype Elem a = Elem { getElem :: a }->-> instance Measured (Sum Int) (Elem a) where->     measure (Elem _) = Sum 1->-> newtype Seq a = Seq (FingerTree (Sum Int) (Elem a))--Then the measure of a subsequence is simply its length.-This representation supports log-time extraction of subsequences:--> take :: Int -> Seq a -> Seq a-> take k (Seq xs) = Seq (takeUntil (> Sum k) xs)->-> drop :: Int -> Seq a -> Seq a-> drop k (Seq xs) = Seq (dropUntil (> Sum k) xs)--The module @Data.Sequence@ is an optimized instantiation of this type.--For further examples, see "Data.IntervalMap.FingerTree" and-"Data.PriorityQueue.FingerTree".---}

@@ -1,220 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe                  #-}-#endif-#if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE AutoDeriveTypeable    #-}-#endif--------------------------------------------------------------------------------- |--- Module      :  Data.PriorityQueue.FingerTree--- Copyright   :  (c) Ross Paterson 2008--- License     :  BSD-style--- 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://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--- 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 HaskellWorks.Data.IntervalMap.FingerTree (-    -- * Intervals-    Interval(..), point,-    -- * Interval maps-    IntervalMap(..), empty, singleton, insert, union,-    -- * Searching-    search, intersections, dominators-    ) where--import           HaskellWorks.Data.FingerTree (FingerTree, Measured (..),-                                               ViewL (..), (<|), (><))-import qualified HaskellWorks.Data.FingerTree as FT--import           Control.Applicative          ((<$>))-import           Control.DeepSeq-import           Data.Foldable                (Foldable (foldMap))-import           Data.Monoid-import           Data.Traversable             (Traversable (traverse))-import           GHC.Generics--------------------------------------- 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, Generic, NFData)---- | 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 (Generic, NFData)--instance Functor (Node v) where-    fmap f (Node i x) = Node i (f x)--instance Foldable (Node v) where-    foldMap f (Node _ x) = f x--instance Traversable (Node v) where-    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 deriving (Generic, NFData)--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)--instance (Ord v) => Measured (IntInterval v) (Node v a) where-    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))-    deriving (Generic, NFData)--- ordered lexicographically by interval--instance Functor (IntervalMap v) where-    fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t)--instance Foldable (IntervalMap v) where-    foldMap f (IntervalMap t) = foldMap (foldMap f) t--instance Traversable (IntervalMap v) where-    traverse f (IntervalMap t) =-        IntervalMap <$> FT.unsafeTraverse (traverse f) t---- | 'empty' and 'union'.-instance (Ord v) => Monoid (IntervalMap v a) where-    mempty = empty-    mappend = union---- | /O(1)/.  The empty interval map.-empty :: (Ord v) => IntervalMap v a-empty = IntervalMap FT.empty---- | /O(1)/.  Interval map with a single entry.-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.--- 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) _ 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-    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-            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.-intersections :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)]-intersections i = inRange (low i) (high i)---- | /O(k log (n/\//k))/.  All intervals that contain the given interval,--- in lexicographical order.-dominators :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)]-dominators i = inRange (high i) (low i)---- | /O(k log (n/\//k))/.  All intervals that contain the given point,--- in lexicographical order.-search :: (Ord v) => v -> IntervalMap v a -> [(Interval v, a)]-search p = inRange p p---- | /O(k log (n/\//k))/.  All intervals that intersect with the given--- 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'--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--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")]--mathematicians :: IntervalMap Int String-mathematicians = mkMap [-    (1642, 1727, "Newton"),-    (1646, 1716, "Leibniz"),-    (1707, 1783, "Euler"),-    (1736, 1813, "Lagrange"),-    (1777, 1855, "Gauss"),-    (1811, 1831, "Galois")]--}

@@ -1,181 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe #-}-#endif-#if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE AutoDeriveTypeable #-}-#endif--------------------------------------------------------------------------------- |--- Module      :  Data.PriorityQueue.FingerTree--- Copyright   :  (c) Ross Paterson 2008--- License     :  BSD-style--- 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://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.--- On the other hand, they are stable, so they can be used for fair--- queueing.  They are also shallower, so that 'fmap' consumes less--- space.------ An amortized running time is given for each operation, with /n/--- referring to the size of the priority queue.  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 HaskellWorks.Data.PriorityQueue.FingerTree (-    PQueue,-    -- * Construction-    empty,-    singleton,-    union,-    insert,-    add,-    fromList,-    -- * Deconstruction-    null,-    minView,-    minViewWithKey-    ) where--import qualified HaskellWorks.Data.FingerTree as FT-import HaskellWorks.Data.FingerTree (FingerTree, (<|), (|>), (><), ViewL(..), Measured(..))--import Control.Arrow ((***))-import Data.Foldable (Foldable(foldMap))-import Data.Monoid-import Prelude hiding (null)--data Entry k v = Entry k v--instance Functor (Entry k) where-    fmap f (Entry k v) = Entry k (f v)--instance Foldable (Entry k) where-    foldMap f (Entry _ v) = f v--data Prio k v = NoPrio | Prio k v--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--instance Ord k => Measured (Prio k v) (Entry k v) where-    measure (Entry k v) = Prio k v---- | Priority queues.-newtype PQueue k v = PQueue (FingerTree (Prio k v) (Entry k v))--instance Ord k => Functor (PQueue k) where-    fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs)--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'--instance Ord k => Monoid (PQueue k v) where-    mempty = empty-    mappend = union---- | /O(1)/. The empty priority queue.-empty :: Ord k => PQueue k v-empty = PQueue FT.empty---- | /O(1)/. A singleton priority queue.-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.------ * @'insert' k v q = 'union' ('singleton' k v) q@------ If @q@ contains entries with the same priority @k@, 'minView' of--- @'insert' k v q@ will return them after this one.-insert :: Ord k => k -> v -> PQueue k v -> PQueue k v-insert k v (PQueue q) = PQueue (Entry k v <| q)---- | /O(log n)/. Add a (priority, value) pair to the back of a priority queue.------ * @'add' k v q = 'union' q ('singleton' k v)@------ If @q@ contains entries with the same priority @k@, 'minView' of--- @'add' k v q@ will return them before this one.-add :: Ord k => k -> v -> PQueue k v -> PQueue k v-add k v (PQueue q) = PQueue (q |> Entry k v)---- | /O(log(min(n1,n2)))/. Concatenate two priority queues.--- 'union' is associative, with identity 'empty'.------ If there are entries with the same priority in both arguments, 'minView'--- of @'union' xs ys@ will return those from @xs@ before those from @ys@.-union :: Ord k => PQueue k v -> PQueue k v -> PQueue k v-union (PQueue xs) (PQueue ys) = PQueue (xs >< ys)---- | /O(n)/. Create a priority queue from a finite list of priorities--- and values.-fromList :: Ord k => [(k, v)] -> PQueue k v-fromList = foldr (uncurry insert) empty---- | /O(1)/. Is this the empty priority queue?-null :: Ord k => PQueue k v -> Bool-null (PQueue q) = FT.null q---- | /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.------  * @'minView' 'empty' = 'Nothing'@------  * @'minView' ('singleton' k v) = 'Just' (v, 'empty')@----minView :: Ord k => PQueue k v -> Maybe (v, PQueue k v)-minView q = fmap (snd *** id) (minViewWithKey q)---- | /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.------  * @'minViewWithKey' 'empty' = 'Nothing'@------  * @'minViewWithKey' ('singleton' k v) = 'Just' ((k, v), 'empty')@------  * If @'minViewWithKey' qi = 'Just' ((ki, vi), qi')@ and @k1 <= k2@,---    then @'minViewWithKey' ('union' q1 q2) = 'Just' ((k1, v1), 'union' q1' q2)@------  * If @'minViewWithKey' qi = 'Just' ((ki, vi), qi')@ and @k2 < k1@,---    then @'minViewWithKey' ('union' q1 q2) = 'Just' ((k2, v2), 'union' q1 q2')@----minViewWithKey :: Ord k => PQueue k v -> Maybe ((k, v), PQueue k v)-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--below :: Ord k => k -> Prio k v -> Bool-below _ NoPrio = False-below k (Prio k' _) = k' <= k

@@ -1,54 +1,79 @@-Name:           hw-fingertree-Version:        0.1.0.0-Cabal-Version:  >= 1.8-Copyright:      (c) 2006 Ross Paterson, Ralf Hinze-License:        BSD3-License-File:   LICENSE-Maintainer:     Ross Paterson <R.Paterson@city.ac.uk>-bug-reports:    http://hub.darcs.net/ross/fingertree/issues-Category:       Data Structures-Synopsis:       Generic finger-tree structure, with example instances-Description:-                A general sequence representation with arbitrary+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8cd50b9741a1c8a2bcc9297a6ee8ba24104ddc058fb32364d45037c5f0958bf1++name:           hw-fingertree+version:        0.1.0.1+synopsis:       Generic finger-tree structure, with example instances+description:    A general sequence representation with arbitrary                 annotations, for use as a base for implementations of                 various collection types, with examples, 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://staff.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.+                <http://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+category:       Data Structures+homepage:       https://github.com/haskell-works/hw-fingertree#readme+bug-reports:    https://github.com/haskell-works/hw-fingertree/issues+maintainer:     John Ky <newhoggy@gmail.com>+copyright:      (c) 2006 Ross Paterson,+                Ralf Hinze,+                (c) 2017-2018 John Ky+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10 -Source-Repository head-  Type: git-  Location: https://github.com/haskell-works/hw-fingertree+source-repository head+  type: git+  location: https://github.com/haskell-works/hw-fingertree -Library-  Build-Depends:  base < 6-                , deepseq-  Extensions:   MultiParamTypeClasses-                FunctionalDependencies-                FlexibleInstances-                UndecidableInstances-  Exposed-Modules:-                HaskellWorks.Data.FingerTree-                HaskellWorks.Data.IntervalMap.FingerTree-                HaskellWorks.Data.PriorityQueue.FingerTree+library+  hs-source-dirs:+      src+  build-depends:+      base <6+    , deepseq+  exposed-modules:+      HaskellWorks.Data.FingerTree+      HaskellWorks.Data.IntervalMap.FingerTree+      HaskellWorks.Data.PriorityQueue.FingerTree+  other-modules:+      Paths_hw_fingertree+  default-language: Haskell2010 -Test-suite ft-properties+test-suite hw-fingertree-tests   type: exitcode-stdio-1.0-  main-is: tests/ft-properties.hs+  main-is: Spec.hs+  hs-source-dirs:+      tests+      src   cpp-options: -DTESTING   build-depends:-                base >= 4.2 && < 6,-                deepseq,-                HUnit,-                QuickCheck,-                test-framework,-                test-framework-hunit,-                test-framework-quickcheck2+      HUnit+    , QuickCheck+    , base >=4.2 && <6+    , deepseq+    , hedgehog+    , hspec+    , hw-fingertree+    , hw-hspec-hedgehog+    , test-framework+    , test-framework-hunit+    , test-framework-quickcheck2+  other-modules:+      HaskellWorks.Data.FingerTree.Gen+      HaskellWorks.Data.FingerTreeSpec+      HaskellWorks.Data.FingerTree+      HaskellWorks.Data.IntervalMap.FingerTree+      HaskellWorks.Data.PriorityQueue.FingerTree+      Paths_hw_fingertree+  default-language: Haskell2010

@@ -0,0 +1,878 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE DeriveAnyClass         #-}+{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE UndecidableInstances   #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe                   #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE AutoDeriveTypeable     #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.FingerTree+-- Copyright   :  (c) Ross Paterson, Ralf Hinze 2006+-- 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.+--    <http://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 HaskellWorks.Data.FingerTree (+#if TESTING+    FingerTree(..), Digit(..), Node(..), deep, node2, node3,+#else+    FingerTree,+#endif+    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 Control.DeepSeq+import Data.Foldable       (Foldable (foldMap), toList)+import Data.Monoid+import GHC.Generics        (Generic)++import qualified Data.Semigroup as S++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, Generic, NFData)++-- | 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, Generic, NFData)++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++instance Measured v a => S.Semigroup (FingerTree v a) where+  (<>) = (><)+  {-# INLINE (<>) #-}++-- | 'empty' and '><'.+instance Measured v a => Monoid (FingerTree v a) where+  mempty = empty+  {-# INLINE mempty #-}+  mappend = (><)+  {-# INLINE 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, Generic, NFData)++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, Generic, NFData)++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)+    deriving (+#if TESTING+    Show,+#endif+    Generic, NFData)++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++-- | /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++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 Eq a => Eq (FingerTree v a) where+    xs == ys = toList xs == toList ys++instance Ord a => Ord (FingerTree v a) where+    compare xs ys = compare (toList xs) (toList ys)++#if !TESTING+instance Show a => Show (FingerTree v a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (toList xs)+#endif++-- | 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+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 :: (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 (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 `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 (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++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 _ 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       =  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 _ 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 'Sum' monoid as a measure:++> newtype Elem a = Elem { getElem :: a }+>+> instance Measured (Sum Int) (Elem a) where+>     measure (Elem _) = Sum 1+>+> newtype Seq a = Seq (FingerTree (Sum Int) (Elem a))++Then the measure of a subsequence is simply its length.+This representation supports log-time extraction of subsequences:++> take :: Int -> Seq a -> Seq a+> take k (Seq xs) = Seq (takeUntil (> Sum k) xs)+>+> drop :: Int -> Seq a -> Seq a+> drop k (Seq xs) = Seq (dropUntil (> Sum k) xs)++The module @Data.Sequence@ is an optimized instantiation of this type.++For further examples, see "Data.IntervalMap.FingerTree" and+"Data.PriorityQueue.FingerTree".++-}

@@ -0,0 +1,235 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe                  #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE AutoDeriveTypeable    #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.PriorityQueue.FingerTree+-- Copyright   :  (c) Ross Paterson 2008+-- License     :  BSD-style+-- 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://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+-- 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 HaskellWorks.Data.IntervalMap.FingerTree (+    -- * Intervals+    Interval(..), point,+    -- * Interval maps+    IntervalMap(..), empty, singleton, insert, union,+    -- * Searching+    search, intersections, dominators+    ) where++import Control.Applicative          ((<$>))+import Control.DeepSeq+import Data.Foldable                (Foldable (foldMap))+import Data.Monoid+import Data.Traversable             (Traversable (traverse))+import GHC.Generics+import HaskellWorks.Data.FingerTree (FingerTree, Measured (..), ViewL (..), (<|), (><))++import qualified Data.Semigroup               as S+import qualified HaskellWorks.Data.FingerTree as FT++----------------------------------+-- 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, Generic, NFData)++-- | 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 (Generic, NFData)++instance Functor (Node v) where+    fmap f (Node i x) = Node i (f x)++instance Foldable (Node v) where+    foldMap f (Node _ x) = f x++instance Traversable (Node v) where+    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 deriving (Generic, NFData)++appendInterval :: Ord v => IntInterval v -> IntInterval v -> IntInterval v+appendInterval (NoInterval       ) (i                   ) = i+appendInterval (i                ) (NoInterval          ) = i+appendInterval (IntInterval _ hi1) (IntInterval int2 hi2) = IntInterval int2 (max hi1 hi2)+{-# INLINE appendInterval #-}++instance Ord v => S.Semigroup (IntInterval v) where+  (<>) = appendInterval+  {-# INLINE (<>) #-}++instance Ord v => Monoid (IntInterval v) where+  mempty = NoInterval+  {-# INLINE mempty #-}+  mappend = appendInterval+  {-# INLINE mappend #-}++instance (Ord v) => Measured (IntInterval v) (Node v a) where+    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))+    deriving (Generic, NFData)+-- ordered lexicographically by interval++instance Functor (IntervalMap v) where+    fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t)++instance Foldable (IntervalMap v) where+    foldMap f (IntervalMap t) = foldMap (foldMap f) t++instance Traversable (IntervalMap v) where+    traverse f (IntervalMap t) =+        IntervalMap <$> FT.unsafeTraverse (traverse f) t++instance (Ord v) => S.Semigroup (IntervalMap v a) where+  (<>) = union+  {-# INLINE (<>) #-}++-- | 'empty' and 'union'.+instance (Ord v) => Monoid (IntervalMap v a) where+    mempty = empty+    {-# INLINE mempty #-}+    mappend = union+    {-# INLINE mappend #-}++-- | /O(1)/.  The empty interval map.+empty :: (Ord v) => IntervalMap v a+empty = IntervalMap FT.empty++-- | /O(1)/.  Interval map with a single entry.+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.+-- 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) _ 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+    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+            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.+intersections :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)]+intersections i = inRange (low i) (high i)++-- | /O(k log (n/\//k))/.  All intervals that contain the given interval,+-- in lexicographical order.+dominators :: (Ord v) => Interval v -> IntervalMap v a -> [(Interval v, a)]+dominators i = inRange (high i) (low i)++-- | /O(k log (n/\//k))/.  All intervals that contain the given point,+-- in lexicographical order.+search :: (Ord v) => v -> IntervalMap v a -> [(Interval v, a)]+search p = inRange p p++-- | /O(k log (n/\//k))/.  All intervals that intersect with the given+-- 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'++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++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")]++mathematicians :: IntervalMap Int String+mathematicians = mkMap [+    (1642, 1727, "Newton"),+    (1646, 1716, "Leibniz"),+    (1707, 1783, "Euler"),+    (1736, 1813, "Lagrange"),+    (1777, 1855, "Gauss"),+    (1811, 1831, "Galois")]+-}

@@ -0,0 +1,196 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe                  #-}+#endif+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE AutoDeriveTypeable    #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.PriorityQueue.FingerTree+-- Copyright   :  (c) Ross Paterson 2008+-- License     :  BSD-style+-- 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://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.+-- On the other hand, they are stable, so they can be used for fair+-- queueing.  They are also shallower, so that 'fmap' consumes less+-- space.+--+-- An amortized running time is given for each operation, with /n/+-- referring to the size of the priority queue.  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 HaskellWorks.Data.PriorityQueue.FingerTree (+    PQueue,+    -- * Construction+    empty,+    singleton,+    union,+    insert,+    add,+    fromList,+    -- * Deconstruction+    null,+    minView,+    minViewWithKey+    ) where++import Control.Arrow                ((***))+import Data.Foldable                (Foldable (foldMap))+import Data.Monoid+import HaskellWorks.Data.FingerTree (FingerTree, Measured (..), ViewL (..), (<|), (><), (|>))+import Prelude                      hiding (null)++import qualified Data.Semigroup               as S+import qualified HaskellWorks.Data.FingerTree as FT++data Entry k v = Entry k v++instance Functor (Entry k) where+    fmap f (Entry k v) = Entry k (f v)++instance Foldable (Entry k) where+    foldMap f (Entry _ v) = f v++data Prio k v = NoPrio | Prio k v++appendPrio :: Ord k => Prio k v -> Prio k v -> Prio k v+appendPrio x             NoPrio        = x+appendPrio NoPrio        y             = y+appendPrio x@(Prio kx _) y@(Prio ky _) = if kx <= ky then x else y+{-# INLINE appendPrio #-}++instance Ord k => S.Semigroup (Prio k v) where+  (<>) = appendPrio+  {-# INLINE (<>) #-}++instance Ord k => Monoid (Prio k v) where+    mempty  = NoPrio+    {-# INLINE mempty #-}+    mappend = appendPrio+    {-# INLINE mappend #-}++instance Ord k => Measured (Prio k v) (Entry k v) where+    measure (Entry k v) = Prio k v++-- | Priority queues.+newtype PQueue k v = PQueue (FingerTree (Prio k v) (Entry k v))++instance Ord k => Functor (PQueue k) where+    fmap f (PQueue xs) = PQueue (FT.fmap' (fmap f) xs)++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'++instance Ord k => S.Semigroup (PQueue k v) where+  (<>) = union+  {-# INLINE (<>) #-}++instance Ord k => Monoid (PQueue k v) where+  mempty = empty+  {-# INLINE mempty #-}+  mappend = union+  {-# INLINE mappend #-}++-- | /O(1)/. The empty priority queue.+empty :: Ord k => PQueue k v+empty = PQueue FT.empty++-- | /O(1)/. A singleton priority queue.+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.+--+-- * @'insert' k v q = 'union' ('singleton' k v) q@+--+-- If @q@ contains entries with the same priority @k@, 'minView' of+-- @'insert' k v q@ will return them after this one.+insert :: Ord k => k -> v -> PQueue k v -> PQueue k v+insert k v (PQueue q) = PQueue (Entry k v <| q)++-- | /O(log n)/. Add a (priority, value) pair to the back of a priority queue.+--+-- * @'add' k v q = 'union' q ('singleton' k v)@+--+-- If @q@ contains entries with the same priority @k@, 'minView' of+-- @'add' k v q@ will return them before this one.+add :: Ord k => k -> v -> PQueue k v -> PQueue k v+add k v (PQueue q) = PQueue (q |> Entry k v)++-- | /O(log(min(n1,n2)))/. Concatenate two priority queues.+-- 'union' is associative, with identity 'empty'.+--+-- If there are entries with the same priority in both arguments, 'minView'+-- of @'union' xs ys@ will return those from @xs@ before those from @ys@.+union :: Ord k => PQueue k v -> PQueue k v -> PQueue k v+union (PQueue xs) (PQueue ys) = PQueue (xs >< ys)++-- | /O(n)/. Create a priority queue from a finite list of priorities+-- and values.+fromList :: Ord k => [(k, v)] -> PQueue k v+fromList = foldr (uncurry insert) empty++-- | /O(1)/. Is this the empty priority queue?+null :: Ord k => PQueue k v -> Bool+null (PQueue q) = FT.null q++-- | /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.+--+--  * @'minView' 'empty' = 'Nothing'@+--+--  * @'minView' ('singleton' k v) = 'Just' (v, 'empty')@+--+minView :: Ord k => PQueue k v -> Maybe (v, PQueue k v)+minView q = fmap (snd *** id) (minViewWithKey q)++-- | /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.+--+--  * @'minViewWithKey' 'empty' = 'Nothing'@+--+--  * @'minViewWithKey' ('singleton' k v) = 'Just' ((k, v), 'empty')@+--+--  * If @'minViewWithKey' qi = 'Just' ((ki, vi), qi')@ and @k1 <= k2@,+--    then @'minViewWithKey' ('union' q1 q2) = 'Just' ((k1, v1), 'union' q1' q2)@+--+--  * If @'minViewWithKey' qi = 'Just' ((ki, vi), qi')@ and @k2 < k1@,+--    then @'minViewWithKey' ('union' q1 q2) = 'Just' ((k2, v2), 'union' q1 q2')@+--+minViewWithKey :: Ord k => PQueue k v -> Maybe ((k, v), PQueue k v)+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++below :: Ord k => k -> Prio k v -> Bool+below _ NoPrio      = False+below k (Prio k' _) = k' <= k

@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts #-}++module HaskellWorks.Data.FingerTree.Gen where++import Control.Monad+import HaskellWorks.Data.FingerTree+import Hedgehog++import qualified Hedgehog.Gen             as G+import qualified Hedgehog.Internal.Gen    as G+import qualified Hedgehog.Internal.Shrink as S+import qualified Hedgehog.Range           as R++genList :: MonadGen m => Range Int -> m a -> m [a]+genList range gen =+  G.sized $ \size ->+    (traverse snd =<<) .+    G.ensure (G.atLeast $ R.lowerBound size range) .+    G.shrink S.list $ do+      k <- G.integral_ range+      replicateM k (G.freeze gen)++shrinkFingerTree :: Measured v a => FingerTree v a -> [FingerTree v a]+shrinkFingerTree (Deep _ (One a) Empty (One b)) = [Single a, Single b]+shrinkFingerTree (Deep _ pr m sf) =+    [deep pr' m  sf  | pr' <- shrinkDigit      pr] +++    [deep pr  m' sf  | m'  <- shrinkFingerTree m ] +++    [deep pr  m  sf' | sf' <- shrinkDigit      sf]+shrinkFingerTree (Single x) = []+shrinkFingerTree Empty = []++fingerTree :: (MonadGen m, Measured v a) => m a -> m (FingerTree v a)+fingerTree gen = G.sized $ \size -> genSizedFingerTree size gen++genSizedFingerTree :: (MonadGen m, Measured v a) => Size -> m a -> m (FingerTree v a)+genSizedFingerTree n gen = G.shrink shrinkFingerTree $ case n of+    0 -> return Empty+    1 -> Single <$> gen+    n -> deep <$> (One <$> gen) <*> genSizedFingerTree (n `div` 2) (genSizedNode (n `div` 2) gen) <*> (One <$> gen)++shrinkNode :: Measured v a => Node v a -> [Node v a]+shrinkNode (Node2 _ a b) = []+shrinkNode (Node3 _ a b c) = [node2 a  b, node2 a c, node2 b c]++genSizedNode :: (MonadGen m, Measured v a) => Size -> m a -> m (Node v a)+genSizedNode n gen = G.shrink shrinkNode $ G.choice+    [ node2 <$> gen <*> gen+    , node3 <$> gen <*> gen <*> gen+    ]++shrinkDigit :: Digit a -> [Digit a]+shrinkDigit (One a)         = []+shrinkDigit (Two a b)       = [One a, One b]+shrinkDigit (Three a b c)   = [Two a b, Two a c, Two b c]+shrinkDigit (Four a b c d)  = [Three a b c, Three a b d, Three a c d, Three b c d]

@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.FingerTreeSpec (spec) where++import Control.Applicative          (Applicative (..))+import Control.Monad                (ap)+import Data.Foldable                (Foldable (foldMap, foldl, foldr), all, toList)+import Data.Functor                 ((<$>))+import Data.List                    (inits)+import Data.Monoid                  (Monoid (..))+import Data.Traversable             (traverse)+import HaskellWorks.Data.FingerTree+import HaskellWorks.Hspec.Hedgehog+import Hedgehog                     hiding (evalM)+import Prelude                      hiding (null, reverse)+import Test.Hspec++import qualified HaskellWorks.Data.FingerTree.Gen as G+import qualified Hedgehog.Gen                     as G+import qualified Hedgehog.Range                   as R+import qualified Prelude                          as P++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: redundant bracket"          :: String) #-}++spec :: Spec+spec = do+  it "foldr" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    foldr (:) [] xs === P.foldr (:) [] (toList xs)+  it "foldl" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    foldl (flip (:)) [] xs === P.foldl (flip (:)) [] (toList xs)+  it "(==)" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    (xs == ys) === (toList xs == toList ys)+  it "compare" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    compare xs ys === compare (toList xs) (toList ys)+  it "mappend" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (mappend xs ys) ~== toList xs ++ toList ys+  it "empty" $ require $ property $ do+    toList' (empty :: Seq Int) === Just []+  it "singletone" $ require $ property $ do+    x <- forAll (G.int R.constantBounded)+    toList' (singleton x) ~== [x]+  it "(<|)" $ require $ property $ do+    x  <- forAll (G.int R.constantBounded)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (x <| xs) ~== x : toList xs+  it "(|>)" $ require $ property $ do+    x  <- forAll (G.int R.constantBounded)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (xs |> x) ~== toList xs ++ [x]+  it "(><)" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    ys <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (xs >< ys) ~== toList xs ++ toList ys+  it "fromList" $ require $ property $ do+    xs <- forAll (G.list (R.linear 0 100) (G.int R.constantBounded))+    toList' (fromList xs) ~== xs+  it "null" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    null xs === P.null (toList xs)+  it "viewl" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    case viewl xs of+      EmptyL    -> P.null (toList xs) === True+      x :< xs'  -> do+        valid xs' === True+        toList xs === x : toList xs'+  it "viewr" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    case viewr xs of+      EmptyR    -> P.null (toList xs) === True+      xs' :> x  -> do+        valid xs' === True+        toList xs === toList xs' ++ [x]+  it "split" $ require $ property $ do+    n <- forAll (G.int R.constantBounded)+    let p ys = P.length ys > n+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toListPair' (split p xs) ~== P.splitAt n (toList xs)+  it "takeUntil" $ require $ property $ do+    n <- forAll (G.int R.constantBounded)+    let p ys = P.length ys > n+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (takeUntil p xs) ~== P.take n (toList xs)+  it "dropUntil" $ require $ property $ do+    n <- forAll (G.int R.constantBounded)+    let p ys = P.length ys > n+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (dropUntil p xs) ~== P.drop n (toList xs)+  it "reverse" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (reverse xs) ~== P.reverse (toList xs)+  it "fmap" $ require $ property $ do+    let f = Just+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (fmap' f xs) ~== map f (toList xs)+  it "fmapWithPos" $ require $ property $ do+    let f = (,)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    let xs_list = toList xs+    toList' (fmapWithPos f xs) ~== zipWith f (inits xs_list) xs_list+  it "traverse" $ require $ property $ do+    let f x = do+          n <- step+          return (n, x)+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    toList' (evalM (traverse' f xs)) ~== evalM (traverse f (toList xs))+  it "traverseWithPos" $ require $ property $ do+    xs <- forAll (G.fingerTree (G.int R.constantBounded))+    let f xs y = do+          n <- step+          return (xs, n, y)+    let xs_list = toList xs+    toList' (evalM (traverseWithPos f xs)) ~== evalM (traverse (uncurry f) (zip (inits xs_list) xs_list))++infix 4 ~==++(~==) :: (Show a, Eq a) => Maybe a -> a -> PropertyT IO ()+(~==) = maybe (const failure) (===)++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 x = M $ \ n -> (n, x)+    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 = return+    (<*>) = ap++step :: M Int+step = M $ \ n -> (n+1, n)++toListPair' ::+    (Eq a, Measured [a] a, Valid a, Eq b, Measured [b] b, Valid b) =>+        (Seq a, Seq b) -> Maybe ([a], [b])+toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys++toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]+toList' xs+  | valid xs = Just (toList xs)+  | otherwise = Nothing++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 Int 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 [Int] Int where+    measure x = [x]++instance Measured [Maybe a] (Maybe a) where+    measure x = [x]++instance Measured [(a, b)] (a, b) where+    measure x = [x]++instance Measured [(a, b, c)] (a, b, c) where+    measure x = [x]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -1,337 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- QuickCheck properties for Data.FingerTree--module Main where--import HaskellWorks.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.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-    , testProperty "split" prop_split-    , testProperty "takeUntil" prop_takeUntil-    , testProperty "dropUntil" prop_dropUntil-    , testProperty "reverse" prop_reverse-    , testProperty "fmap'" prop_fmap'-    -- , testProperty "fmapWithPos" prop_fmapWithPos -- (slow)-    , testProperty "traverse'" prop_traverse'-    -- , testProperty "traverseWithPos" prop_traverseWithPos -- (slow)-    ] 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 => Maybe a -> a -> Bool-(~=) = maybe (const False) (==)---- 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--toListPair' ::-    (Eq a, Measured [a] a, Valid a, Eq b, Measured [b] b, Valid b) =>-        (Seq a, Seq b) -> Maybe ([a], [b])-toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys---- 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 =-    toList' (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 =-    toList' (singleton x) ~= [x]--prop_cons :: A -> Seq A -> Bool-prop_cons x xs =-    toList' (x <| xs) ~= x : toList xs--prop_snoc :: Seq A -> A -> Bool-prop_snoc xs x =-    toList' (xs |> x) ~= toList xs ++ [x]--prop_append :: Seq A -> Seq A -> Bool-prop_append xs ys =-    toList' (xs >< ys) ~= toList xs ++ toList ys--prop_fromList :: [A] -> Bool-prop_fromList xs =-    toList' (fromList xs) ~= xs---- * Deconstruction--prop_null :: Seq A -> Bool-prop_null xs =-    null xs == Prelude.null (toList xs)--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]--prop_split :: Int -> Seq A -> Bool-prop_split n xs =-    toListPair' (split p xs) ~= Prelude.splitAt n (toList xs)-  where p ys = Prelude.length ys > n--prop_takeUntil :: Int -> Seq A -> Bool-prop_takeUntil n xs =-    toList' (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 =-    toList' (dropUntil p xs) ~= Prelude.drop n (toList xs)-  where p ys = Prelude.length ys > n---- * Transformation--prop_reverse :: Seq A -> Bool-prop_reverse xs =-    toList' (reverse xs) ~= Prelude.reverse (toList xs)--prop_fmap' :: Seq A -> Bool-prop_fmap' xs =-    toList' (fmap' f xs) ~= map f (toList xs)-  where f = Just--prop_fmapWithPos :: Seq A -> Bool-prop_fmapWithPos xs =-    toList' (fmapWithPos f xs) ~= zipWith f (inits xs_list) xs_list-  where-    f = (,)-    xs_list = toList xs--prop_traverse' :: Seq A -> Bool-prop_traverse' xs =-    toList' (evalM (traverse' f xs)) ~= evalM (traverse f (toList xs))-  where-    f x = do-        n <- step-        return (n, x)--prop_traverseWithPos :: Seq A -> Bool-prop_traverseWithPos xs =-    toList' (evalM (traverseWithPos f xs)) ~= evalM (traverse (uncurry f) (zip (inits xs_list) xs_list))-  where-    f xs y = do-        n <- step-        return (xs, n, y)-    xs_list = toList xs--{- untested:-traverseWithPos--}----------------------------------------------------------------------------- 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]--instance Measured [(a, b, c)] (a, b, c) where-    measure x = [x]----------------------------------------------------------------------------- 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 x = M $ \ n -> (n, x)-    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 = return-    (<*>) = ap--step :: M Int-step = M $ \ n -> (n+1, n)