Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-fingertree for openSUSE:Factory checked in at 2022-02-11 23:08:49 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-fingertree (Old) and /work/SRC/openSUSE:Factory/.ghc-fingertree.new.1956 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-fingertree" Fri Feb 11 23:08:49 2022 rev:3 rq:953456 version:0.1.5.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-fingertree/ghc-fingertree.changes 2020-12-22 11:39:33.297506052 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-fingertree.new.1956/ghc-fingertree.changes 2022-02-11 23:10:45.575180259 +0100 @@ -1,0 +2,8 @@ +Sat Jan 29 16:53:47 UTC 2022 - Peter Simons <[email protected]> + +- Update fingertree to version 0.1.5.0. + 0.1.5.0 Ross Paterson <[email protected]> Jan 2022 + * Added foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext (James Cranch) + * Fixed bug in traverseWithContext + +------------------------------------------------------------------- Old: ---- fingertree-0.1.4.2.tar.gz New: ---- fingertree-0.1.5.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-fingertree.spec ++++++ --- /var/tmp/diff_new_pack.JuKPs0/_old 2022-02-11 23:10:46.011181519 +0100 +++ /var/tmp/diff_new_pack.JuKPs0/_new 2022-02-11 23:10:46.015181532 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-fingertree # -# Copyright (c) 2020 SUSE LLC +# Copyright (c) 2022 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name fingertree %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.1.4.2 +Version: 0.1.5.0 Release: 0 Summary: Generic finger-tree structure, with example instances License: BSD-3-Clause ++++++ fingertree-0.1.4.2.tar.gz -> fingertree-0.1.5.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fingertree-0.1.4.2/Data/FingerTree.hs new/fingertree-0.1.5.0/Data/FingerTree.hs --- old/fingertree-0.1.4.2/Data/FingerTree.hs 2018-12-06 15:47:27.000000000 +0100 +++ new/fingertree-0.1.5.0/Data/FingerTree.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 : [email protected] -- 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) - 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 +mapWPDigit f vl (Four a b c d) = Four (f vl a) (f vla b) (f vlab c) (f vlabc d) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vlabc = vlab `mappend` measure c -- | Map all elements of the tree with a function that also takes the -- measure of the prefix to the left and of the suffix to the right of @@ -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) - 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 + vbr = measure b `mappend` vr +mapWCNode f vl (Node3 _ a b c) vr = + node3 (f vl a vbcr) (f vla b vcr) (f vlab c vr) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr mapWCDigit :: (Measured v a) => (v -> a -> v -> b) -> v -> Digit a -> v -> Digit b mapWCDigit f vl (One a) vr = One (f vl a vr) -mapWCDigit f vl (Two a b) vr = Two (f vl a 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) - 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 + vbr = measure b `mappend` vr +mapWCDigit f vl (Three a b c) vr = + Three (f vl a vbcr) (f vla b vcr) (f vlab c vr) + where + vla = vl `mappend` measure a + vlab = vla `mappend` measure b + vcr = measure c `mappend` vr + vbcr = measure b `mappend` vcr mapWCDigit f vl (Four a b c d) vr = - Four (f vl a 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 } > diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fingertree-0.1.4.2/Data/IntervalMap/FingerTree.hs new/fingertree-0.1.5.0/Data/IntervalMap/FingerTree.hs --- old/fingertree-0.1.4.2/Data/IntervalMap/FingerTree.hs 2018-12-06 15:47:27.000000000 +0100 +++ new/fingertree-0.1.5.0/Data/IntervalMap/FingerTree.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 ----------------------------------------------------------------------------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fingertree-0.1.4.2/Data/PriorityQueue/FingerTree.hs new/fingertree-0.1.5.0/Data/PriorityQueue/FingerTree.hs --- old/fingertree-0.1.4.2/Data/PriorityQueue/FingerTree.hs 2018-12-06 15:47:27.000000000 +0100 +++ new/fingertree-0.1.5.0/Data/PriorityQueue/FingerTree.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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@ -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fingertree-0.1.4.2/changelog new/fingertree-0.1.5.0/changelog --- old/fingertree-0.1.4.2/changelog 2018-12-06 15:47:27.000000000 +0100 +++ new/fingertree-0.1.5.0/changelog 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,9 @@ -*-change-log-*- +0.1.5.0 Ross Paterson <[email protected]> Jan 2022 + * Added foldlWithPos, foldrWithPos, foldlWithContext, foldrWithContext (James Cranch) + * Fixed bug in traverseWithContext + 0.1.4.2 Ross Paterson <[email protected]> Dec 2018 * Fixed bug in search diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fingertree-0.1.4.2/fingertree.cabal new/fingertree-0.1.5.0/fingertree.cabal --- old/fingertree-0.1.4.2/fingertree.cabal 2018-12-06 15:47:27.000000000 +0100 +++ new/fingertree-0.1.5.0/fingertree.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/fingertree-0.1.4.2/tests/ft-properties.hs new/fingertree-0.1.5.0/tests/ft-properties.hs --- old/fingertree-0.1.4.2/tests/ft-properties.hs 2018-12-06 15:47:27.000000000 +0100 +++ new/fingertree-0.1.5.0/tests/ft-properties.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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,59 +191,130 @@ 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 = 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 - f = (,) + 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 v y = do + n <- step + return (WithPos v (n, y)) + xs_list = toList xs + +prop_traverseWithContext :: FingerTree MA VA -> Bool +prop_traverseWithContext xs = + evalM (traverseWithContext f xs) ~= evalM (traverse uncurry_f (zip3 (prefixes xs_list) xs_list (suffixes xs_list))) where - f xs y = do + uncurry_f (vl, y, vr) = f vl y vr + f vl y vr = do n <- step - return (xs, n, y) + return (WithContext vl (n, y) vr) xs_list = toList xs -{- untested: -traverseWithPos --} +-- 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 @@ -343,6 +419,57 @@ 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 ------------------------------------------------------------------------
