fingertree 0.1.4.2 → 0.1.5.0
raw patch · 6 files changed
+488/−131 lines, 6 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Data.FingerTree: foldlWithContext :: Measured v a => (b -> v -> a -> v -> b) -> b -> FingerTree v a -> b
+ Data.FingerTree: foldlWithPos :: Measured v a => (b -> v -> a -> b) -> b -> FingerTree v a -> b
+ Data.FingerTree: foldrWithContext :: Measured v a => (v -> a -> v -> b -> b) -> b -> FingerTree v a -> b
+ Data.FingerTree: foldrWithPos :: Measured v a => (v -> a -> b -> b) -> b -> FingerTree v a -> b
- Data.FingerTree: Position :: FingerTree v a -> a -> FingerTree v a -> SearchResult v a
+ Data.FingerTree: Position :: !FingerTree v a -> a -> !FingerTree v a -> SearchResult v a
Files
- Data/FingerTree.hs +313/−87
- Data/IntervalMap/FingerTree.hs +1/−1
- Data/PriorityQueue/FingerTree.hs +2/−2
- changelog +4/−0
- fingertree.cabal +1/−1
- tests/ft-properties.hs +167/−40
Data/FingerTree.hs view
@@ -9,13 +9,15 @@ #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DeriveGeneric #-} #endif-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 {-# LANGUAGE AutoDeriveTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.FingerTree--- Copyright : (c) Ross Paterson, Ralf Hinze 2006+-- Copyright : Ross Paterson and Ralf Hinze 2006,+-- Ross Paterson 2006-2022,+-- James Cranch 2021 -- License : BSD-style -- Maintainer : R.Paterson@city.ac.uk -- Stability : experimental@@ -68,6 +70,8 @@ reverse, -- ** Maps fmap', fmapWithPos, fmapWithContext, unsafeFmap,+ -- ** Folds+ foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext, -- ** Traversals traverse', traverseWithPos, traverseWithContext, unsafeTraverse, -- * Example@@ -287,39 +291,40 @@ 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)+mapWPTree f vl (Single x) = Single (f vl x)+mapWPTree f vl (Deep _ pr m sf) =+ deep (mapWPDigit f vl pr)+ (mapWPTree (mapWPNode f) vlp m)+ (mapWPDigit f vlpm sf) where- vpr = v `mappend` measure pr- vm = vpr `mappend` measure m+ vlp = vl `mappend` measure pr+ vlpm = vlp `mappend` measure m mapWPNode :: (Measured v1 a1, Measured v2 a2) => (v1 -> a1 -> a2) -> v1 -> Node v1 a1 -> Node v2 a2-mapWPNode f v (Node2 _ a b) = node2 (f v a) (f va b)+mapWPNode f vl (Node2 _ a b) = node2 (f vl a) (f vla b) where- va = v `mappend` measure a-mapWPNode f v (Node3 _ a b c) = node3 (f v a) (f va b) (f vab c)+ vla = vl `mappend` measure a+mapWPNode f vl (Node3 _ a b c) = node3 (f vl a) (f vla b) (f vlab c) where- va = v `mappend` measure a- vab = va `mappend` measure b+ va = vl `mappend` measure a+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b mapWPDigit :: (Measured v a) => (v -> a -> b) -> v -> Digit a -> Digit b-mapWPDigit f v (One a) = One (f v a)-mapWPDigit f v (Two a b) = Two (f v a) (f va b)+mapWPDigit f vl (One a) = One (f vl a)+mapWPDigit f vl (Two a b) = Two (f vl a) (f vla b) where- va = v `mappend` measure a-mapWPDigit f v (Three a b c) = Three (f v a) (f va b) (f vab c)+ vla = vl `mappend` measure a+mapWPDigit f vl (Three a b c) = Three (f vl a) (f vla b) (f vlab 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)+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+mapWPDigit f vl (Four a b c d) = Four (f vl a) (f vla b) (f vlab c) (f vlabc d) where- va = v `mappend` measure a- vab = va `mappend` measure b- vabc = vab `mappend` measure c+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vlabc = vlab `mappend` measure c -- | Map all elements of the tree with a function that also takes the -- measure of the prefix to the left and of the suffix to the right of@@ -347,39 +352,41 @@ mapWCNode :: (Measured v1 a1, Measured v2 a2) => (v1 -> a1 -> v1 -> a2) -> v1 -> Node v1 a1 -> v1 -> Node v2 a2-mapWCNode f vl (Node2 _ a b) vr = node2 (f vl a vb) (f va b vr)+mapWCNode f vl (Node2 _ a b) vr = node2 (f vl a vbr) (f vla b vr) where- va = vl `mappend` measure a- vb = measure b `mappend` vr-mapWCNode f vl (Node3 _ a b c) vr = node3 (f vl a vbc) (f va b vc) (f vab c vr)+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr+mapWCNode f vl (Node3 _ a b c) vr =+ node3 (f vl a vbcr) (f vla b vcr) (f vlab c vr) where- va = vl `mappend` measure a- vab = va `mappend` measure b- vbc = measure b `mappend` vc- vc = measure c `mappend` vr+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr mapWCDigit :: (Measured v a) => (v -> a -> v -> b) -> v -> Digit a -> v -> Digit b mapWCDigit f vl (One a) vr = One (f vl a vr)-mapWCDigit f vl (Two a b) vr = Two (f vl a vb) (f va b vr)+mapWCDigit f vl (Two a b) vr = Two (f vl a vbr) (f vla b vr) where- va = vl `mappend` measure a- vb = measure b `mappend` vr-mapWCDigit f vl (Three a b c) vr = Three (f vl a vbc) (f va b vc) (f vab c vr)+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr+mapWCDigit f vl (Three a b c) vr =+ Three (f vl a vbcr) (f vla b vcr) (f vlab c vr) where- va = vl `mappend` measure a- vab = va `mappend` measure b- vbc = measure b `mappend` vc- vc = measure c `mappend` vr+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr mapWCDigit f vl (Four a b c d) vr =- Four (f vl a vbcd) (f va b vcd) (f vab c vd) (f vabc d vr)+ Four (f vl a vbcdr) (f vla b vcdr) (f vlab c vdr) (f vlabc d vr) where- va = vl `mappend` measure a- vab = va `mappend` measure b- vabc = vab `mappend` measure c- vbcd = measure b `mappend` vcd- vcd = measure c `mappend` vd- vd = measure d `mappend` vr+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vlabc = vlab `mappend` measure c+ vdr = measure d `mappend` vr+ vcdr = measure c `mappend` vdr+ vbcdr = measure b `mappend` vcdr -- | Like 'fmap', but safe only if the function preserves the measure. unsafeFmap :: (a -> b) -> FingerTree v a -> FingerTree v b@@ -392,6 +399,224 @@ unsafeFmapNode f (Node2 v a b) = Node2 v (f a) (f b) unsafeFmapNode f (Node3 v a b c) = Node3 v (f a) (f b) (f c) +-- | Fold the tree from the left with a function that also takes the+-- measure of the prefix to the left of the element.+--+-- @since 0.1.5.0+foldlWithPos :: (Measured v a) =>+ (b -> v -> a -> b) -> b -> FingerTree v a -> b+foldlWithPos f z = foldlWPTree f z mempty++foldlWPTree :: (Measured v a) =>+ (b -> v -> a -> b) -> b -> v -> FingerTree v a -> b+foldlWPTree _ z _ Empty = z+foldlWPTree f z vl (Single x) = f z vl x+foldlWPTree f z vl (Deep _ pr m sf) = zpms+ where+ vlp = vl `mappend` measure pr+ vlpm = vlp `mappend` measure m+ zp = foldlWPDigit f z vl pr+ zpm = foldlWPTree (foldlWPNode f) zp vlp m+ zpms = foldlWPDigit f zpm vlpm sf++foldlWPNode :: (Measured v a) =>+ (b -> v -> a -> b) -> b -> v -> Node v a -> b+foldlWPNode f z vl (Node2 _ a b) = f (f z vl a) vla b+ where+ vla = vl `mappend` measure a+foldlWPNode f z vl (Node3 _ a b c) = f (f (f z vl a) vla b) vlab c+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b++foldlWPDigit :: (Measured v a) =>+ (b -> v -> a -> b) -> b -> v -> Digit a -> b+foldlWPDigit f z vl (One a) = f z vl a+foldlWPDigit f z vl (Two a b) = f (f z vl a) vla b+ where+ vla = vl `mappend` measure a+foldlWPDigit f z vl (Three a b c) = f (f (f z vl a) vla b) vlab c+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+foldlWPDigit f z vl (Four a b c d) = f (f (f (f z vl a) vla b) vlab c) vlabc d+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vlabc = vlab `mappend` measure c++-- | Fold the tree from the right with a function that also takes the+-- measure of the prefix to the left of the element.+--+-- @since 0.1.5.0+foldrWithPos :: (Measured v a) =>+ (v -> a -> b -> b) -> b -> FingerTree v a -> b+foldrWithPos f z = foldrWPTree f z mempty++foldrWPTree :: (Measured v a) =>+ (v -> a -> b -> b) -> b -> v -> FingerTree v a -> b+foldrWPTree _ z _ Empty = z+foldrWPTree f z vl (Single x) = f vl x z+foldrWPTree f z vl (Deep _ pr m sf) = zpms+ where+ vlp = vl `mappend` measure pr+ vlpm = vlp `mappend` measure m+ zpms = foldrWPDigit f zms vl pr+ zms = foldrWPTree (foldrWPNode f) zs vlp m+ zs = foldrWPDigit f z vlpm sf++-- different argument order for convenience+foldrWPNode :: (Measured v a) =>+ (v -> a -> b -> b) -> v -> Node v a -> b -> b+foldrWPNode f vl (Node2 _ a b) z = f vl a (f vla b z)+ where+ vla = vl `mappend` measure a+foldrWPNode f vl (Node3 _ a b c) z = f vl a (f vla b (f vlab c z))+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b++foldrWPDigit :: (Measured v a) =>+ (v -> a -> b -> b) -> b -> v -> Digit a -> b+foldrWPDigit f z vl (One a) = f vl a z+foldrWPDigit f z vl (Two a b) = f vl a (f vla b z)+ where+ vla = vl `mappend` measure a+foldrWPDigit f z vl (Three a b c) = f vl a (f vla b (f vlab c z))+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+foldrWPDigit f z vl (Four a b c d) = f vl a (f vla b (f vlab c (f vlabc d z)))+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vlabc = vlab `mappend` measure c++-- | Fold the tree from the left with a function that also takes the+-- measure of the prefix to the left of the element and the measure of+-- the suffix to the right of the element.+--+-- @since 0.1.5.0+foldlWithContext :: (Measured v a) =>+ (b -> v -> a -> v -> b) -> b -> FingerTree v a -> b+foldlWithContext f z t = foldlWCTree f z mempty t mempty++foldlWCTree :: (Measured v a) =>+ (b -> v -> a -> v -> b) -> b -> v -> FingerTree v a -> v -> b+foldlWCTree _ z _ Empty _ = z+foldlWCTree f z vl (Single x) vr = f z vl x vr+foldlWCTree f z vl (Deep _ pr m sf) vr = zpms+ where+ vlp = vl `mappend` measure pr+ vlpm = vlp `mappend` vm+ vmsr = vm `mappend` vsr+ vsr = measure sf `mappend` vr+ vm = measure m+ zp = foldlWCDigit f z vl pr vmsr+ zpm = foldlWCTree (foldlWCNode f) zp vlp m vsr+ zpms = foldlWCDigit f zpm vlpm sf vr++foldlWCNode :: (Measured v a) =>+ (b -> v -> a -> v -> b) -> b -> v -> Node v a -> v -> b+foldlWCNode f z vl (Node2 _ a b) vr = f (f z vl a vbr) vla b vr+ where+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr+foldlWCNode f z vl (Node3 _ a b c) vr =+ f (f (f z vl a vbcr) vla b vcr) vlab c vr+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr++foldlWCDigit :: (Measured v a) =>+ (b -> v -> a -> v -> b) -> b -> v -> Digit a -> v -> b+foldlWCDigit f z vl (One a) vr = f z vl a vr+foldlWCDigit f z vl (Two a b) vr = f (f z vl a vbr) vla b vr+ where+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr+foldlWCDigit f z vl (Three a b c) vr =+ f (f (f z vl a vbcr) vla b vcr) vlab c vr+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr+foldlWCDigit f z vl (Four a b c d) vr =+ f (f (f (f z vl a vbcdr) vla b vcdr) vlab c vdr) vlabc d vr+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vlabc = vlab `mappend` measure c+ vdr = measure d `mappend` vr+ vcdr = measure c `mappend` vdr+ vbcdr = measure b `mappend` vcdr++-- | Fold the tree from the right with a function that also takes the+-- measure of the prefix to the left of the element and the measure of+-- the suffix to the right of the element.+--+-- @since 0.1.5.0+foldrWithContext :: (Measured v a) =>+ (v -> a -> v -> b -> b) -> b -> FingerTree v a -> b+foldrWithContext f z t = foldrWCTree f z mempty t mempty++foldrWCTree :: (Measured v a) =>+ (v -> a -> v -> b -> b) -> b -> v -> FingerTree v a -> v -> b+foldrWCTree _ z _ Empty _ = z+foldrWCTree f z vl (Single x) vr = f vl x vr z+foldrWCTree f z vl (Deep _ pr m sf) vr = zpms+ where+ vlp = vl `mappend` measure pr+ vlpm = vlp `mappend` vm+ vmsr = vm `mappend` vsr+ vsr = measure sf `mappend` vr+ vm = measure m+ zpms = foldrWCDigit f zms vl pr vmsr+ zms = foldrWCTree (foldrWCNode f) zs vlp m vsr+ zs = foldrWCDigit f z vlpm sf vr++-- different argument order for convenience+foldrWCNode :: (Measured v a) =>+ (v -> a -> v -> b -> b) -> v -> Node v a -> v -> b -> b+foldrWCNode f vl (Node2 _ a b) vr z = f vl a vbr (f vla b vr z)+ where+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr+foldrWCNode f vl (Node3 _ a b c) vr z =+ f vl a vbcr (f vla b vcr (f vlab c vr z))+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr++foldrWCDigit :: (Measured v a) =>+ (v -> a -> v -> b -> b) -> b -> v -> Digit a -> v -> b+foldrWCDigit f z vl (One a) vr = f vl a vr z+foldrWCDigit f z vl (Two a b) vr = f vl a vbr (f vla b vr z)+ where+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr+foldrWCDigit f z vl (Three a b c) vr =+ f vl a vbcr (f vla b vcr (f vlab c vr z))+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr+foldrWCDigit f z vl (Four a b c d) vr =+ f vl a vbcdr (f vla b vcdr (f vlab c vdr (f vlabc d vr z)))+ where+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vlabc = vlab `mappend` measure c+ vdr = measure d `mappend` vr+ vcdr = measure c `mappend` vdr+ vbcdr = measure b `mappend` vcdr+ -- | Like 'traverse', but with constraints on the element types. traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) => (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)@@ -481,41 +706,41 @@ traverseWCNode :: (Measured v1 a1, Measured v2 a2, Applicative f) => (v1 -> a1 -> v1 -> f a2) -> v1 -> Node v1 a1 -> v1 -> f (Node v2 a2)-traverseWCNode f vl (Node2 _ a b) vr = node2 <$> f vl a vb <*> f va b vr+traverseWCNode f vl (Node2 _ a b) vr = node2 <$> f vl a vbr <*> f vla b vr where- va = vl `mappend` measure a- vb = measure a `mappend` vr+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr traverseWCNode f vl (Node3 _ a b c) vr =- node3 <$> f vl a vbc <*> f va b vc <*> f vab c vr+ node3 <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr where- va = vl `mappend` measure a- vab = va `mappend` measure b- vc = measure c `mappend` vr- vbc = measure b `mappend` vc+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr traverseWCDigit :: (Measured v a, Applicative f) => (v -> a -> v -> f b) -> v -> Digit a -> v -> f (Digit b) traverseWCDigit f vl (One a) vr = One <$> f vl a vr-traverseWCDigit f vl (Two a b) vr = Two <$> f vl a vb <*> f va b vr+traverseWCDigit f vl (Two a b) vr = Two <$> f vl a vbr <*> f vla b vr where- va = vl `mappend` measure a- vb = measure a `mappend` vr+ vla = vl `mappend` measure a+ vbr = measure b `mappend` vr traverseWCDigit f vl (Three a b c) vr =- Three <$> f vl a vbc <*> f va b vc <*> f vab c vr+ Three <$> f vl a vbcr <*> f vla b vcr <*> f vlab c vr where- va = vl `mappend` measure a- vab = va `mappend` measure b- vc = measure c `mappend` vr- vbc = measure b `mappend` vc+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vcr = measure c `mappend` vr+ vbcr = measure b `mappend` vcr traverseWCDigit f vl (Four a b c d) vr =- Four <$> f vl a vbcd <*> f va b vcd <*> f vab c vd <*> f vabc d vr+ Four <$> f vl a vbcdr <*> f vla b vcdr <*> f vlab c vdr <*> f vlabc d vr where- va = vl `mappend` measure a- vab = va `mappend` measure b- vabc = vab `mappend` measure c- vd = measure d `mappend` vr- vcd = measure c `mappend` vd- vbcd = measure b `mappend` vcd+ vla = vl `mappend` measure a+ vlab = vla `mappend` measure b+ vlabc = vlab `mappend` measure c+ vdr = measure d `mappend` vr+ vcdr = measure c `mappend` vdr+ vbcdr = measure b `mappend` vcdr -- | Like 'traverse', but safe only if the function preserves the measure. unsafeTraverse :: (Applicative f) =>@@ -885,7 +1110,7 @@ -- -- @since 0.1.2.0 data SearchResult v a- = Position (FingerTree v a) a (FingerTree v a)+ = Position !(FingerTree v a) a !(FingerTree v a) -- ^ A tree opened at a particular element: the prefix to the -- left, the element, and the suffix to the right. | OnLeft@@ -961,13 +1186,13 @@ searchTree _ _ Empty _ = illegal_argument "searchTree" searchTree _ _ (Single x) _ = Split Empty x Empty searchTree p vl (Deep _ pr m sf) vr- | p vlp vmsr = let Split l x r = searchDigit p vl pr vmsr- in Split (maybe Empty digitToTree l) x (deepL r m sf)- | p vlpm vsr = let Split ml xs mr = searchTree p vlp m vsr- Split l x r = searchNode p (vlp `mappend` measure ml) xs (measure mr `mappend` vsr)- in Split (deepR pr ml l) x (deepL r mr sf)- | otherwise = let Split l x r = searchDigit p vlpm sf vr- in Split (deepR pr m l) x (maybe Empty digitToTree r)+ | p vlp vmsr = case searchDigit p vl pr vmsr of+ Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)+ | p vlpm vsr = case searchTree p vlp m vsr of+ Split ml xs mr -> case searchNode p (vlp `mappend` measure ml) xs (measure mr `mappend` vsr) of+ Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)+ | otherwise = case searchDigit p vlpm sf vr of+ Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) where vlp = vl `mappend` measure pr vlpm = vlp `mappend` vm@@ -1054,20 +1279,20 @@ 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+data Split t a = Split !t a !t splitTree :: (Measured v a) => (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a splitTree _ _ Empty = illegal_argument "splitTree" splitTree _ _ (Single x) = Split Empty x Empty splitTree p i (Deep _ pr m sf)- | p vpr = let Split l x r = splitDigit p i pr- in Split (maybe Empty digitToTree l) x (deepL r m sf)- | p vm = let Split ml xs mr = splitTree p vpr m- Split l x r = splitNode p (vpr `mappend` measure ml) xs- in Split (deepR pr ml l) x (deepL r mr sf)- | otherwise = let Split l x r = splitDigit p vm sf- in Split (deepR pr m l) x (maybe Empty digitToTree r)+ | p vpr = case splitDigit p i pr of+ Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)+ | p vm = case splitTree p vpr m of+ Split ml xs mr -> case splitNode p (vpr `mappend` measure ml) xs of+ Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)+ | otherwise = case splitDigit p vm sf of+ Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r) where vpr = i `mappend` measure pr vm = vpr `mappend` measure m@@ -1156,7 +1381,8 @@ 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:+Simple sequences can be implemented using a 'Data.Monoid.Sum' monoid+as a measure: > newtype Elem a = Elem { getElem :: a } >
Data/IntervalMap/FingerTree.hs view
@@ -6,7 +6,7 @@ #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DeriveGeneric #-} #endif-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------
Data/PriorityQueue/FingerTree.hs view
@@ -6,7 +6,7 @@ #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE DeriveGeneric #-} #endif-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 802 {-# LANGUAGE AutoDeriveTypeable #-} #endif -----------------------------------------------------------------------------@@ -163,7 +163,7 @@ singleton :: Ord k => k -> v -> PQueue k v singleton k v = PQueue (FT.singleton (Entry k v)) --- | /O(log n)/. Add a (priority, value) pair to the front of a priority queue.+-- | /O(1)/. Add a (priority, value) pair to the front of a priority queue. -- -- * @'insert' k v q = 'union' ('singleton' k v) q@ --
changelog view
@@ -1,5 +1,9 @@ -*-change-log-*- +0.1.5.0 Ross Paterson <R.Paterson@city.ac.uk> Jan 2022+ * Added foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext (James Cranch)+ * Fixed bug in traverseWithContext+ 0.1.4.2 Ross Paterson <R.Paterson@city.ac.uk> Dec 2018 * Fixed bug in search
fingertree.cabal view
@@ -1,5 +1,5 @@ Name: fingertree-Version: 0.1.4.2+Version: 0.1.5.0 Cabal-Version: 1.18 Copyright: (c) 2006 Ross Paterson, Ralf Hinze License: BSD3
tests/ft-properties.hs view
@@ -48,9 +48,15 @@ , testProperty "dropUntil" prop_dropUntil , testProperty "reverse" prop_reverse , testProperty "fmap'" prop_fmap'- -- , testProperty "fmapWithPos" prop_fmapWithPos -- (slow)+ , testProperty "fmapWithPos" prop_fmapWithPos+ , testProperty "fmapWithContext" prop_fmapWithContext+ , testProperty "foldlWithPos" prop_foldlWithPos+ , testProperty "foldlWithContext" prop_foldlWithContext+ , testProperty "foldrWithPos" prop_foldrWithPos+ , testProperty "foldrWithContext" prop_foldrWithContext , testProperty "traverse'" prop_traverse'- -- , testProperty "traverseWithPos" prop_traverseWithPos -- (slow)+ , testProperty "traverseWithPos" prop_traverseWithPos+ , testProperty "traverseWithContext" prop_traverseWithContext ] runner_opts where runner_opts = mempty { ropt_test_options = Just test_opts }@@ -71,8 +77,8 @@ infix 4 ~= -(~=) :: Eq a => Maybe a -> a -> Bool-(~=) = maybe (const False) (==)+(~=) :: (Eq a, Eq v, Measured v a, Valid a) => FingerTree v a -> [a] -> Bool+s ~= xs = valid s && toList s == xs -- Partial conversion of an output sequence to a list. toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]@@ -80,11 +86,6 @@ | 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@@ -111,7 +112,7 @@ prop_mappend :: Seq A -> Seq A -> Bool prop_mappend xs ys =- toList' (mappend xs ys) ~= toList xs ++ toList ys+ mappend xs ys ~= toList xs ++ toList ys -- * Construction @@ -121,23 +122,23 @@ prop_singleton :: A -> Bool prop_singleton x =- toList' (singleton x) ~= [x]+ singleton x ~= [x] prop_cons :: A -> Seq A -> Bool prop_cons x xs =- toList' (x <| xs) ~= x : toList xs+ x <| xs ~= x : toList xs prop_snoc :: Seq A -> A -> Bool prop_snoc xs x =- toList' (xs |> x) ~= toList xs ++ [x]+ xs |> x ~= toList xs ++ [x] prop_append :: Seq A -> Seq A -> Bool prop_append xs ys =- toList' (xs >< ys) ~= toList xs ++ toList ys+ xs >< ys ~= toList xs ++ toList ys prop_fromList :: [A] -> Bool prop_fromList xs =- toList' (fromList xs) ~= xs+ fromList xs ~= xs -- * Deconstruction @@ -145,6 +146,8 @@ prop_null xs = null xs == Prelude.null (toList xs) +-- ** Examining the ends+ prop_viewl :: Seq A -> Bool prop_viewl xs = case viewl xs of@@ -157,6 +160,8 @@ EmptyR -> Prelude.null (toList xs) xs' :> x -> valid xs' && toList xs == toList xs' ++ [x] +-- ** Search+ prop_search :: Int -> Seq A -> Bool prop_search n xs = case search p xs of@@ -164,13 +169,13 @@ OnLeft -> n >= len || null xs OnRight -> n < 0 Nowhere -> error "impossible: the predicate is monotonic"- where p vl vr = Prelude.length vl >= len - n && Prelude.length vr <= n-- len = length xs+ where+ p vl vr = Prelude.length vl >= len - n && Prelude.length vr <= n - indexFromEnd :: Int -> [a] -> Maybe a- indexFromEnd i = listToMaybe . drop i . Prelude.reverse+ len = length xs + indexFromEnd :: Int -> [a] -> Maybe a+ indexFromEnd i = listToMaybe . drop i . Prelude.reverse test_search :: Assertion test_search = do@@ -186,60 +191,131 @@ Position _ x _ -> Just x _ -> Nothing +-- ** Splitting+ 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+ s_front ~= l_front && s_back ~= l_back+ where+ p ys = Prelude.length ys > n+ (s_front, s_back) = split p xs+ (l_front, l_back) = Prelude.splitAt n (toList xs) prop_takeUntil :: Int -> Seq A -> Bool prop_takeUntil n xs =- toList' (takeUntil p xs) ~= Prelude.take n (toList xs)- where p ys = Prelude.length ys > n+ 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+ 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)+ reverse xs ~= Prelude.reverse (toList xs) +-- ** Maps+ prop_fmap' :: Seq A -> Bool prop_fmap' xs =- toList' (fmap' f xs) ~= map f (toList xs)- where f = Just+ fmap' f xs ~= map f (toList xs)+ where+ f = Just -prop_fmapWithPos :: Seq A -> Bool+prop_fmapWithPos :: FingerTree MA VA -> Bool prop_fmapWithPos xs =- toList' (fmapWithPos f xs) ~= zipWith f (inits xs_list) xs_list+ fmapWithPos f xs ~= zipWith f (prefixes xs_list) xs_list where- f = (,)+ f = WithPos xs_list = toList xs +prop_fmapWithContext :: FingerTree MA VA -> Bool+prop_fmapWithContext xs =+ fmapWithContext f xs ~= zipWith3 f (prefixes xs_list) xs_list (suffixes xs_list)+ where+ f = WithContext+ xs_list = toList xs++-- ** Folds++prop_foldlWithPos :: FingerTree MA VA -> Bool+prop_foldlWithPos xs =+ foldlWithPos f z xs == foldl uncurry_f z (zip (prefixes xs_list) xs_list)+ where+ z = []+ f vxs v x = WithPos v x:vxs+ uncurry_f vxs (v, x) = f vxs v x+ xs_list = toList xs++prop_foldlWithContext :: FingerTree MA VA -> Bool+prop_foldlWithContext xs =+ foldlWithContext f z xs == foldl uncurry_f z (zip3 (prefixes xs_list) xs_list (suffixes xs_list))+ where+ z = []+ f vxs vl x vr = WithContext vl x vr:vxs+ uncurry_f vxs (vl, x, vr) = f vxs vl x vr+ xs_list = toList xs++prop_foldrWithPos :: FingerTree MA VA -> Bool+prop_foldrWithPos xs =+ foldrWithPos f z xs == foldr uncurry_f z (zip (prefixes xs_list) xs_list)+ where+ z = []+ f v x vxs = WithPos v x:vxs+ uncurry_f (v, x) vxs = f v x vxs+ xs_list = toList xs++prop_foldrWithContext :: FingerTree MA VA -> Bool+prop_foldrWithContext xs =+ foldrWithContext f z xs == foldr uncurry_f z (zip3 (prefixes xs_list) xs_list (suffixes xs_list))+ where+ z = []+ f vl x vr vxs = WithContext vl x vr:vxs+ uncurry_f (vl, x, vr) vxs = f vl x vr vxs+ xs_list = toList xs++-- ** Traversals+ prop_traverse' :: Seq A -> Bool prop_traverse' xs =- toList' (evalM (traverse' f xs)) ~= evalM (traverse f (toList xs))+ 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 :: FingerTree MA VA -> Bool prop_traverseWithPos xs =- toList' (evalM (traverseWithPos f xs)) ~= evalM (traverse (uncurry f) (zip (inits xs_list) xs_list))+ evalM (traverseWithPos f xs) ~= evalM (traverse (uncurry f) (zip (prefixes xs_list) xs_list)) where- f xs y = do+ f v y = do n <- step- return (xs, n, y)+ return (WithPos v (n, y)) xs_list = toList xs -{- untested:-traverseWithPos--}+prop_traverseWithContext :: FingerTree MA VA -> Bool+prop_traverseWithContext xs =+ evalM (traverseWithContext f xs) ~= evalM (traverse uncurry_f (zip3 (prefixes xs_list) xs_list (suffixes xs_list)))+ where+ uncurry_f (vl, y, vr) = f vl y vr+ f vl y vr = do+ n <- step+ return (WithContext vl (n, y) vr)+ xs_list = toList xs +-- measure to the left of each value+prefixes :: (Measured v a) => [a] -> [v]+prefixes = scanl (<>) mempty . map measure++-- measure to the right of each value+suffixes :: (Measured v a) => [a] -> [v]+suffixes = tail . scanr (<>) mempty . map measure+ ------------------------------------------------------------------------ -- QuickCheck ------------------------------------------------------------------------@@ -341,6 +417,57 @@ instance Measured [(a, b, c)] (a, b, c) where measure x = [x]++------------------------------------------------------------------------+-- A noncommutative monoid as a measure: semidirect product+------------------------------------------------------------------------++data MA = MA Int Int+ deriving (Eq, Show)++instance Semigroup MA where+ MA a x <> MA b y = MA (a*b) (x + a*y)++instance Monoid MA where+ mempty = MA 1 0++instance Valid MA where+ valid = const True++newtype VA = VA Int+ deriving (Eq, Show)++instance Measured MA VA where+ measure (VA x) = MA 3 x++instance Arbitrary VA where+ arbitrary = VA <$> arbitrary+ shrink (VA x) = map VA (shrink x)++instance Valid VA where+ valid = const True++------------------------------------------------------------------------+-- Values with positions and contexts+------------------------------------------------------------------------++data WithPos v a = WithPos v a+ deriving (Eq, Show)++instance Monoid v => Measured v (WithPos v a) where+ measure (WithPos v _) = v++instance (Valid v, Valid a) => Valid (WithPos v a) where+ valid (WithPos v x) = valid v && valid x++data WithContext v a = WithContext v a v+ deriving (Eq, Show)++instance Monoid v => Measured v (WithContext v a) where+ measure (WithContext vl _ vr) = vl++instance (Valid v, Valid a) => Valid (WithContext v a) where+ valid (WithContext vl x vr) = valid vl && valid x && valid vr ------------------------------------------------------------------------ -- Simple counting monad