dual-tree 0.2.3.1 → 0.2.3.2

raw patch · 3 files changed

+206/−114 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGES +33/−0
• dual-tree.cabal +4/−4
• src/Data/Tree/DUAL/Internal.hs +169/−110

@@ -1,3 +1,36 @@+* 0.2.3.2: 28 March 2026++- Fix [#16](https://github.com/diagrams/dual-tree/issues/16): Contrary+  to the documentation, `sconcat` often produced deeply nested trees,+  rather than flat ones; the problem is that `sconcat` in auto-derived+  `Semigroup` instances performs a fold with `(<>)`.  This version+  manually reimplements the relevant `Semigroup` instances so that+  `sconcat` now results in flat trees.  There is no semantic+  difference, but this could conceivably lead to better performance in+  cases where `sconcat` is being called on large lists of+  trees. Thanks to [John Z.](https://github.com/machinedgod) for+  reporting the issue.++* 0.2.3.1-r5: 13 May 2025++- Allow monoid-extras-0.7++* 0.2.3.1-r4: 29 Jan 2025++- Allow base-4.21 and test with GHC 9.12++* 0.2.3.1-r3: 18 May 2023++- Allow base-4.20 and test with GHC 9.10++* 0.2.3.1-r2: 21 Oct 2023++- Allow base-4.19 and test with GHC 9.8++* 0.2.3.1-r1: 8 May 2023++- Allow base-4.18 and test with GHC 9.6+ * 0.2.3.1: 17 Aug 2022  - Allow base-4.17 and test with GHC 9.4

@@ -1,5 +1,5 @@ name:                dual-tree-version:             0.2.3.1+version:             0.2.3.2 synopsis:            Rose trees with cached and accumulating monoidal annotations description:         Rose (n-ary) trees with both upwards- (/i.e./                      cached) and downwards-traveling (/i.e./@@ -31,7 +31,7 @@ build-type:          Simple cabal-version:       >=1.10 bug-reports:         https://github.com/diagrams/dual-tree/issues-tested-with:         GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.1+tested-with:         GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 || ==9.10.1 || ==9.12.1 source-repository head   type: git   location: https://github.com/diagrams/dual-tree.git@@ -40,9 +40,9 @@   default-language:  Haskell2010   exposed-modules:   Data.Tree.DUAL                      Data.Tree.DUAL.Internal-  build-depends:     base >= 4.3 && < 4.18,+  build-depends:     base >= 4.3 && < 4.22,                      semigroups >= 0.8 && < 0.21,-                     monoid-extras >= 0.6 && < 0.7+                     monoid-extras >= 0.6 && < 0.8   hs-source-dirs:    src   other-extensions:  GeneralizedNewtypeDeriving,                      MultiParamTypeClasses,

@@ -1,12 +1,11 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ -- | -- Module      :  Data.Tree.DUAL.Internal -- Copyright   :  (c) 2011-2012 Brent Yorgey@@ -30,33 +29,42 @@ -- type system enforces the invariant that there is only one -- representation for the empty tree.  It also allows us to get away -- with only 'Semigroup' constraints in many places.-----------------------------------------------------------------------------------module Data.Tree.DUAL.Internal-       (-         -- * DUAL-trees-         DUALTreeNE(..), DUALTreeU(..), DUALTree(..)--         -- * Constructing DUAL-trees-       , empty, leaf, leafU, annot, applyD+module Data.Tree.DUAL.Internal (+  -- * DUAL-trees+  DUALTreeNE (..),+  DUALTreeU (..),+  DUALTree (..), -         -- * Modifying DUAL-trees-       , applyUpre, applyUpost-       , mapUNE, mapUU, mapU+  -- * Constructing DUAL-trees+  empty,+  leaf,+  leafU,+  annot,+  applyD, -         -- * Accessors and eliminators-       , nonEmpty, getU, foldDUALNE, foldDUAL, flatten+  -- * Modifying DUAL-trees+  applyUpre,+  applyUpost,+  mapUNE,+  mapUU,+  mapU, -       ) where+  -- * Accessors and eliminators+  nonEmpty,+  getU,+  foldDUALNE,+  foldDUAL,+  flatten,+) where -import           Control.Arrow      ((***))-import           Data.List.NonEmpty (NonEmpty (..))+import Control.Arrow ((***))+import qualified Data.Functor as F+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL-import           Data.Maybe         (fromMaybe)-import           Data.Monoid.Action-import           Data.Semigroup-import           Data.Typeable+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid.Action+import Data.Semigroup+import Data.Typeable  ------------------------------------------------------------ -- DUALTreeNE@@ -64,27 +72,33 @@  -- | /Non-empty/ DUAL-trees. data DUALTreeNE d u a l-  = Leaf   u l        -- ^ Leaf with data value and @u@ annotation-  | LeafU  u          -- ^ Leaf with only @u@ annotation-  | Concat (NonEmpty (DUALTreeU d u a l))-                      -- ^ n-way branch, containing a /non-empty/ list-                      --   of subtrees.-  | Act    d (DUALTreeU d u a l)-                      -- ^ @d@ annotation-  | Annot  a (DUALTreeU d u a l)-                      -- ^ Internal data value+  = -- | Leaf with data value and @u@ annotation+    Leaf u l+  | -- | Leaf with only @u@ annotation+    LeafU u+  | -- | n-way branch, containing a /non-empty/ list+    --   of subtrees.+    Concat (NonEmpty (DUALTreeU d u a l))+  | -- | @d@ annotation+    Act d (DUALTreeU d u a l)+  | -- | Internal data value+    Annot a (DUALTreeU d u a l)   deriving (Functor, Typeable, Show, Eq) +-- | The @Semigroup@ instance is carefully crafted so that 'sconcat'+--   creates a flat, rather than deeply nested, tree. instance (Action d u, Semigroup u) => Semigroup (DUALTreeNE d u a l) where-  t1 <> t2   = sconcat (NEL.fromList [t1,t2])-  sconcat    = Concat . NEL.map pullU+  t1 <> t2 = sconcat (NEL.fromList [t1, t2])+  sconcat = Concat . NEL.map pullU -newtype DAct d = DAct { unDAct :: d }+newtype DAct d = DAct {unDAct :: d} -instance (Semigroup d, Semigroup u, Action d u)-    => Action (DAct d) (DUALTreeNE d u a l) where+instance+  (Semigroup d, Semigroup u, Action d u) =>+  Action (DAct d) (DUALTreeNE d u a l)+  where   act (DAct d) (Act d' t) = Act (d <> d') t-  act (DAct d) t          = Act d (pullU t)+  act (DAct d) t = Act d (pullU t)  ------------------------------------------------------------ -- DUALTreeU@@ -92,24 +106,39 @@  -- | A non-empty DUAL-tree paired with a cached @u@ value.  These --   should never be constructed directly; instead, use 'pullU'.-newtype DUALTreeU d u a l = DUALTreeU { unDUALTreeU :: (u, DUALTreeNE d u a l) }-  deriving (Functor, Semigroup, Typeable, Show, Eq)+newtype DUALTreeU d u a l = DUALTreeU {unDUALTreeU :: (u, DUALTreeNE d u a l)}+  deriving (Functor, Typeable, Show, Eq) -overDUALTreeU-  :: ((u, DUALTreeNE d u a l) -> (u', DUALTreeNE d u' a l))-  -> DUALTreeU d u a l -> DUALTreeU d u' a l+-- | The @Semigroup@ instance is carefully crafted so that 'sconcat'+--   creates a flat, rather than deeply nested, tree.  Simply+--   auto-deriving the Semigroup instance produces an 'sconcat'+--   implementation which calls '(<>)' repeatedly, which is not what+--   we want.  Frustratingly, manually defining @sconcat =+--   DUALTreeU . sconcat . fmap unDUALTreeU@ does not work either,+--   since it ends up using 'sconcat' for pairs, which still turns+--   into nested calls to '(<>)'.+instance (Action d u, Semigroup u) => Semigroup (DUALTreeU d u a l) where+  DUALTreeU t1 <> DUALTreeU t2 = DUALTreeU (t1 <> t2)+  sconcat = DUALTreeU . (sconcat *** sconcat) . F.unzip . fmap unDUALTreeU++overDUALTreeU ::+  ((u, DUALTreeNE d u a l) -> (u', DUALTreeNE d u' a l)) ->+  DUALTreeU d u a l ->+  DUALTreeU d u' a l overDUALTreeU f = DUALTreeU . f . unDUALTreeU -instance (Semigroup d, Semigroup u, Action d u)-    => Action (DAct d) (DUALTreeU d u a l) where+instance+  (Semigroup d, Semigroup u, Action d u) =>+  Action (DAct d) (DUALTreeU d u a l)+  where   act d = overDUALTreeU (act (unDAct d) *** act d)  -- | \"Pull\" the root @u@ annotation out into a tuple. pullU :: (Semigroup u, Action d u) => DUALTreeNE d u a l -> DUALTreeU d u a l-pullU t@(Leaf u _)                   = DUALTreeU (u, t)-pullU t@(LeafU u)                    = DUALTreeU (u, t)-pullU t@(Concat ts)                  = DUALTreeU (sconcat . NEL.map (fst . unDUALTreeU) $ ts, t)-pullU t@(Act d (DUALTreeU (u,_)))    = DUALTreeU (act d u, t)+pullU t@(Leaf u _) = DUALTreeU (u, t)+pullU t@(LeafU u) = DUALTreeU (u, t)+pullU t@(Concat ts) = DUALTreeU (sconcat . NEL.map (fst . unDUALTreeU) $ ts, t)+pullU t@(Act d (DUALTreeU (u, _))) = DUALTreeU (act d u, t) pullU t@(Annot _ (DUALTreeU (u, _))) = DUALTreeU (u, t)  ------------------------------------------------------------@@ -140,26 +169,41 @@ --     of subtrees \"does not matter\". -- --   * 'Monoid'. The identity is the empty tree.+newtype DUALTree d u a l = DUALTree {unDUALTree :: Maybe (DUALTreeU d u a l)}+  deriving (Functor, Typeable, Show, Eq) -newtype DUALTree d u a l = DUALTree { unDUALTree :: Maybe (DUALTreeU d u a l) }-  deriving ( Functor, Semigroup, Typeable, Show, Eq )+-- | The @Semigroup@ instance is carefully crafted so that 'sconcat'+--   creates a flat, rather than deeply nested, tree.  Simply+--   auto-deriving the Semigroup instance produces an 'sconcat'+--   implementation which calls '(<>)' repeatedly, which is not what+--   we want.  Manually defining @sconcat = DUALTree . sconcat . fmap+--   unDUALTreeU@ does not even work either, since it ends up using+--   'sconcat' for 'Maybe', which still turns into nested calls to+--   '(<>)'.+instance (Action d u, Semigroup u) => Semigroup (DUALTree d u a l) where+  DUALTree t1 <> DUALTree t2 = DUALTree (t1 <> t2) -overDUALTree-  :: (Maybe (DUALTreeU d u a l) -> Maybe (DUALTreeU d u' a l))-  -> DUALTree d u a l -> DUALTree d u' a l+  sconcat = DUALTree . fmap sconcat . NEL.nonEmpty . catMaybes . NEL.toList . fmap unDUALTree++overDUALTree ::+  (Maybe (DUALTreeU d u a l) -> Maybe (DUALTreeU d u' a l)) ->+  DUALTree d u a l ->+  DUALTree d u' a l overDUALTree f = DUALTree . f . unDUALTree  instance (Semigroup u, Action d u) => Monoid (DUALTree d u a l) where-  mempty  = DUALTree mempty+  mempty = DUALTree mempty   mappend = (<>)-  mconcat []     = mempty-  mconcat (x:xs) = sconcat (x :| xs)+  mconcat [] = mempty+  mconcat (x : xs) = sconcat (x :| xs)  -- | Apply a @d@ annotation at the root of a tree.  Semantically, all --   @u@ annotations are transformed by the action of @d@, although --   operationally @act@ incurs only a constant amount of work.-instance (Semigroup d, Semigroup u, Action d u)-    => Action (DAct d) (DUALTree d u a l) where+instance+  (Semigroup d, Semigroup u, Action d u) =>+  Action (DAct d) (DUALTree d u a l)+  where   act = overDUALTree . fmap . act  ------------------------------------------------------------@@ -200,8 +244,9 @@  -- | Apply a @d@ annotation at the root of a tree, transforming all --   @u@ annotations by the action of @d@.-applyD :: (Semigroup d, Semigroup u, Action d u)-       => d -> DUALTree d u a l -> DUALTree d u a l+applyD ::+  (Semigroup d, Semigroup u, Action d u) =>+  d -> DUALTree d u a l -> DUALTree d u a l applyD = act . DAct  -- | Decompose a DUAL-tree into either @Nothing@ (if empty) or a@@ -226,10 +271,10 @@ --   with the action of @d@) over all the @u@ annotations in a non-empty --   DUAL-tree. mapUNE :: (u -> u') -> DUALTreeNE d u a l -> DUALTreeNE d u' a l-mapUNE f (Leaf u l)  = Leaf (f u) l-mapUNE f (LeafU u)   = LeafU (f u)+mapUNE f (Leaf u l) = Leaf (f u) l+mapUNE f (LeafU u) = LeafU (f u) mapUNE f (Concat ts) = Concat ((NEL.map . mapUU) f ts)-mapUNE f (Act d t)   = Act d (mapUU f t)+mapUNE f (Act d t) = Act d (mapUU f t) mapUNE f (Annot a t) = Annot a (mapUU f t)  -- | Map a function (which must be a monoid homomorphism, and commute@@ -248,7 +293,6 @@ --     * @f (u1 \<\> u2) == f u1 \<\> f u2@ -- --     * @f (act d u) == act d (f u)@--- mapU :: (u -> u') -> DUALTree d u a l -> DUALTree d u' a l mapU = overDUALTree . fmap . mapUU @@ -257,25 +301,32 @@ ------------------------------------------------------------  -- | Fold for non-empty DUAL-trees.-foldDUALNE :: (Semigroup d, Monoid d)-           => (d -> l -> r) -- ^ Process a leaf datum along with the-                            --   accumulation of @d@ values along the-                            --   path from the root-           -> r             -- ^ Replace @LeafU@ nodes-           -> (NonEmpty r -> r)  -- ^ Combine results at a branch node-           -> (d -> r -> r)      -- ^ Process an internal d node-           -> (a -> r -> r)      -- ^ Process an internal datum-           -> DUALTreeNE d u a l -> r-foldDUALNE  = foldDUALNE' Nothing-  where-    foldDUALNE' dacc lf _   _   _    _   (Leaf _ l)  = lf (fromMaybe mempty dacc) l-    foldDUALNE' _    _  lfU _   _    _   (LeafU _)   = lfU-    foldDUALNE' dacc lf lfU con down ann (Concat ts)-      = con (NEL.map (foldDUALNE' dacc lf lfU con down ann . snd . unDUALTreeU) ts)-    foldDUALNE' dacc lf lfU con down ann (Act d t)-      = down d (foldDUALNE' (dacc <> Just d) lf lfU con down ann . snd . unDUALTreeU $ t)-    foldDUALNE' dacc lf lfU con down ann (Annot a t)-      = ann a (foldDUALNE' dacc lf lfU con down ann . snd . unDUALTreeU $ t)+foldDUALNE ::+  (Semigroup d, Monoid d) =>+  -- | Process a leaf datum along with the+  --   accumulation of @d@ values along the+  --   path from the root+  (d -> l -> r) ->+  -- | Replace @LeafU@ nodes+  r ->+  -- | Combine results at a branch node+  (NonEmpty r -> r) ->+  -- | Process an internal d node+  (d -> r -> r) ->+  -- | Process an internal datum+  (a -> r -> r) ->+  DUALTreeNE d u a l ->+  r+foldDUALNE = foldDUALNE' Nothing+ where+  foldDUALNE' dacc lf _ _ _ _ (Leaf _ l) = lf (fromMaybe mempty dacc) l+  foldDUALNE' _ _ lfU _ _ _ (LeafU _) = lfU+  foldDUALNE' dacc lf lfU con down ann (Concat ts) =+    con (NEL.map (foldDUALNE' dacc lf lfU con down ann . snd . unDUALTreeU) ts)+  foldDUALNE' dacc lf lfU con down ann (Act d t) =+    down d (foldDUALNE' (dacc <> Just d) lf lfU con down ann . snd . unDUALTreeU $ t)+  foldDUALNE' dacc lf lfU con down ann (Annot a t) =+    ann a (foldDUALNE' dacc lf lfU con down ann . snd . unDUALTreeU $ t)  -- | Fold for DUAL-trees. It is given access to the internal and leaf --   data, internal @d@ values, and the accumulated @d@ values at each@@ -292,28 +343,36 @@ --   along the path from the root to the leaf. -- --   The result is @Nothing@ if and only if the tree is empty.-foldDUAL :: (Semigroup d, Monoid d)-         => (d -> l -> r)          -- ^ Process a leaf datum along with the-                                   --   accumulation of @d@ values along the-                                   --   path from the root-         -> r                      -- ^ Replace @u@-only nodes-         -> (NonEmpty r -> r)      -- ^ Combine results at a branch node-         -> (d -> r -> r)          -- ^ Process an internal d node-         -> (a -> r -> r)          -- ^ Process an internal datum-         -> DUALTree d u a l -> Maybe r-foldDUAL _ _ _ _ _ (DUALTree Nothing)-  = Nothing-foldDUAL l u c d a (DUALTree (Just (DUALTreeU (_, t))))-  = Just $ foldDUALNE l u c d a t+foldDUAL ::+  (Semigroup d, Monoid d) =>+  -- | Process a leaf datum along with the+  --   accumulation of @d@ values along the+  --   path from the root+  (d -> l -> r) ->+  -- | Replace @u@-only nodes+  r ->+  -- | Combine results at a branch node+  (NonEmpty r -> r) ->+  -- | Process an internal d node+  (d -> r -> r) ->+  -- | Process an internal datum+  (a -> r -> r) ->+  DUALTree d u a l ->+  Maybe r+foldDUAL _ _ _ _ _ (DUALTree Nothing) =+  Nothing+foldDUAL l u c d a (DUALTree (Just (DUALTreeU (_, t)))) =+  Just $ foldDUALNE l u c d a t  -- | A specialized fold provided for convenience: flatten a tree into --   a list of leaves along with their @d@ annotations, ignoring --   internal data values. flatten :: (Semigroup d, Monoid d) => DUALTree d u a l -> [(l, d)]-flatten = fromMaybe []-        . foldDUAL-            (\d l -> [(l, d)])-            []-            (concat . NEL.toList)-            (\_ x -> x)-            (const id)+flatten =+  fromMaybe []+    . foldDUAL+      (\d l -> [(l, d)])+      []+      (concat . NEL.toList)+      (\_ x -> x)+      (const id)