polytree 0.1.1 → 0.1.2
raw patch · 6 files changed
+695/−42 lines, 6 filesdep +process
Dependencies added: process
Files
- LICENCE +1/−1
- README.md +126/−0
- changelog.md +19/−0
- polytree.cabal +37/−14
- src/Data/PolyTree.hs +494/−27
- test/Main.hs +18/−0
LICENCE view
@@ -1,4 +1,4 @@-Copyright 2025 Tony Morris+Copyright 2025-2026 Tony Morris All rights reserved.
+ README.md view
@@ -0,0 +1,126 @@+# polytree++A polymorphic rose tree with different types for node labels and leaf values.++## Overview++The `polytree` library provides `Tree f a b` and `TreeForest f a b` data types where:+- `f` is a polymorphic container type (list, vector, etc.)+- `a` is the type of node labels+- `b` is the type of leaf values++This design allows for flexible tree representations where internal nodes and leaves can have different types, and the choice of container affects performance characteristics.++## Key Features++### Data Types++- **`Tree f a b`** - A tree with labels of type `a` at nodes and values of type `b` at leaves+- **`TreeForest f a b`** - A forest (collection) of trees and leaves+- **Type aliases**: `Tree'`, `TreeList`, `TreeList'`, `Tree1`, `Tree1'`++### Type Class Instances++Comprehensive instances for:+- **Standard classes**: `Eq`, `Ord`, `Show` (with lifted variants `Eq1`, `Eq2`, etc.)+- **Functors**: `Bifunctor`, `Functor`+- **Applicatives**: `Apply`, `Applicative` (operates over leaves with `Monoid`/`Semigroup` on labels)+- **Foldables**: `Bifoldable`, `Foldable`, `Bifoldable1`, `Foldable1`+- **Traversables**: `Bitraversable`, `Traversable`, `Bitraversable1`, `Traversable1`+- **Lens integration**: `Wrapped`, `Plated`, and custom optics++### Optics++Four-level classy optics hierarchy:+- **`GetX`** - Read-only access via `Getter`+- **`HasX`** - Read-write access via `Lens'`+- **`ReviewX`** - Construction via `Review`+- **`AsX`** - Full prism access via `Prism'`++Available for both `Tree` and `TreeForest` types.++### Utility Functions++- **Construction**: `makeTree`, `makeChild`, `makeLeaves`, `makeChildren`, `singleton`+- **Unfolding**: `unfoldTree`, `unfoldTreeM`+- **Traversal**: `dfs` (depth-first), `bfs` (breadth-first)+- **Analysis**: `countNodes`, `countLeaves`, `levels`+- **Transformation**: `pruneLeaves`+- **Conversion**: `baseTree` (to/from `Data.Tree.Tree`)++## Example Usage++```haskell+import Data.PolyTree+import Control.Lens++-- Create a tree with string labels and integer leaves+tree :: TreeList String Int+tree = Tree "root" + (TreeForest + [ Left 42 -- A leaf+ , makeChild "child1" [Left 10, Left 20] -- A subtree+ , makeChild "child2" [] -- An empty subtree+ ])++-- Traverse leaves+>>> toListOf treeLeaves tree+[42,10,20]++-- Map over leaves+>>> fmap (*2) tree+Tree "root" (TreeForest [Left 84,Right (Tree "child1" (TreeForest [Left 20,Left 40])),Right (Tree "child2" (TreeForest []))])++-- Depth-first traversal+>>> dfs tree+Left "root" :| [Right 42,Left "child1",Right 10,Right 20,Left "child2"]++-- Breadth-first traversal+>>> bfs tree+Left "root" :| [Right 42,Left "child1",Left "child2",Right 10,Right 20]++-- Unfold a tree+>>> unfoldTree (\n -> (n, if n > 0 then [Right (n-1)] else [])) 3+Tree 3 (TreeForest [Right (Tree 2 (TreeForest [Right (Tree 1 (TreeForest [Right (Tree 0 (TreeForest []))]))]))])++-- Use applicative instance (operates over leaves with Monoid on labels)+>>> Tree "a" (TreeForest [Left (+1)]) <*> Tree "b" (TreeForest [Left 5])+Tree "ab" (TreeForest [Left 6])+```++## Design Decisions++### Why Different Types for Nodes and Leaves?++Many tree algorithms distinguish between internal nodes (which have structural/organizational data) and leaves (which have payload data). For example:+- Decision trees: nodes contain split criteria, leaves contain predictions+- Expression trees: nodes contain operators, leaves contain values+- File systems: nodes are directories, leaves are files++### Why Polymorphic Container?++The `f` parameter allows you to choose the container type:+- `[]` for simple lists (default, most flexible)+- `Vector` for efficient random access+- `NonEmpty` for non-empty forests (with `Foldable1`/`Traversable1` instances)+- `Identity` for single-child trees++### Why Not Biapplicative?++While `Bifunctor`, `Bifoldable`, and `Bitraversable` instances are possible, `Biapply` and `Biapplicative` instances are **not** implementable due to the recursive `Either`-based structure. The combination of a tree of functions with a single value has no canonical semantics.++## Testing++The library includes comprehensive doctests (115 examples). Run with:++```bash+cabal test+```++## Related Work++- `Data.Tree` from `containers` - Standard rose tree (single type for all nodes)+- `Data.Tree.Class` - Type class approach to trees+- This library's approach: Separate types for nodes/leaves with polymorphic container++
changelog.md view
@@ -1,3 +1,22 @@+0.1.2++* Add comprehensive test infrastructure with 115 doctests+* Add explicit export list for better API control+* Add classy optics hierarchy (GetTree, HasTree, ReviewTree, AsTree and TreeForest variants)+* Add utility functions: singleton, unfoldTree, unfoldTreeM, pruneLeaves, countNodes, countLeaves, levels+* Add makeTree constructor (makeChild now delegates to it)+* Fix CPP conditional import of liftA2 for GHC < 9.6 compatibility+* Document why Biapplicative/Biapply instances are not possible+* Add comprehensive README.md with examples and design decisions+* Add .hlint.yaml and .ormolu configuration files+* Update to cabal-version 2.4 with modern formatting+* Add System-F logo to package description+* Update copyright to 2025-2026+* Change license to BSD-3-Clause (SPDX identifier)+* Add dev flag for -Werror during development+* Simplify build scripts and update GitLab CI to System-F style+* Add GitLab Pages integration for documentation publishing+ 0.1.1 * Make `TreeForest` its own data type
polytree.cabal view
@@ -1,16 +1,20 @@+cabal-version: 2.4 name: polytree-version: 0.1.1+version: 0.1.2 synopsis: A polymorphic rose-tree-description: A rose-tree which has different data in the nodes and leaves-license: BSD3+description:+ A rose-tree which has different data in the nodes and leaves+ .+ <<https://logo.systemf.com.au/systemf-450x450.jpg>>+license: BSD-3-Clause license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>-copyright: Copyright (C) 2025 Tony Morris+copyright: Copyright (C) 2025-2026 Tony Morris category: Data build-type: Simple-extra-source-files: changelog.md-cabal-version: >=1.10+extra-doc-files: changelog.md+ README.md homepage: https://gitlab.com/tonymorris/polytree bug-reports: https://gitlab.com/tonymorris/polytree/issues tested-with: GHC == 9.4.8, GHC == 9.6.5, GHC == 9.8.4, GHC == 9.10.3@@ -20,16 +24,35 @@ location: git@gitlab.com:tonymorris/polytree.git library- exposed-modules:- Data.PolyTree+ exposed-modules: Data.PolyTree - build-depends: base >= 4.9 && < 6- , bifunctors >= 5.6 && < 7- , containers >= 0.6.7 && < 1- , free >= 5.2 && < 6- , lens >= 5 && < 6- , semigroupoids >= 6.0.1 && < 7+ build-depends: base >= 4.9 && < 6+ , bifunctors >= 5.6 && < 7+ , containers >= 0.6.7 && < 1+ , free >= 5.2 && < 6+ , lens >= 5 && < 6+ , semigroupoids >= 6.0.1 && < 7 hs-source-dirs: src++ default-language: Haskell2010++ ghc-options: -Wall++ if flag(dev)+ ghc-options: -Werror++flag dev+ description: Enable -Werror for development+ manual: True+ default: False++test-suite doctest+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base >= 4.9 && < 6+ , process >= 1 && < 2+ build-tool-depends: doctest:doctest >= 0.22 default-language: Haskell2010 ghc-options: -Wall
src/Data/PolyTree.hs view
@@ -1,29 +1,59 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Data.PolyTree where+module Data.PolyTree (+ -- * Types+ Tree(..)+, TreeForest(..)+, Tree'+, TreeForest'+, TreeList+, TreeList'+, Tree1+, Tree1'+ -- * Construction+, makeTree+, makeChild+, makeLeaves+, makeChildren+, singleton+ -- * Traversals+, dfs+, bfs+ -- * Utility+, unfoldTree+, unfoldTreeM+, pruneLeaves+, countNodes+, countLeaves+, levels+ -- * Optics classes+, GetTree(..)+, HasTree(..)+, GetTreeForest(..)+, HasTreeForest(..)+, ReviewTree(..)+, AsTree(..)+, ReviewTreeForest(..)+, AsTreeForest(..)+ -- * Optics+, treeForest'+, treeSubForest+, treeLeaves+, treeForestChildren+ -- * Conversions+, baseTree+) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative ( Applicative(liftA2) )-import Control.Lens- ( view,- iso,- _Left,- _Right,- _Wrapped,- Plated(..),- Iso',- Lens,- Lens',- Prism',- Traversal,- Traversal',- Rewrapped,- Wrapped(..) )+#endif+import Control.Lens hiding ((<.>), levels) import Data.Bifoldable ( Bifoldable(bifoldMap) )-import Data.Bifunctor ( Bifunctor(bimap) ) import Data.Bitraversable ( Bitraversable(..) ) import Data.Functor.Apply ( Apply(liftF2, (<.>)) ) import Data.Functor.Classes@@ -35,25 +65,45 @@ Ord2(..), Show1(liftShowsPrec), Show2(..) )-import Data.Functor.Identity ( Identity(..) )+import Data.Functor.Identity () import Data.List.NonEmpty ( NonEmpty(..), nonEmpty, toList )+import Data.Monoid ( Sum(..) ) import Data.Semigroup.Bifoldable ( Bifoldable1(bifoldMap1) ) import Data.Semigroup.Bitraversable ( Bitraversable1(bitraverse1) ) import Data.Semigroup.Foldable ( Foldable1(foldMap1) )-import Data.Semigroup.Traversable ( Traversable1(traverse1) )+import Data.Semigroup.Traversable () import qualified Data.Tree as Tree -- $setup--- >>> import Control.Lens+-- >>> import Control.Lens hiding ((<.>), levels)+-- >>> import Data.Functor.Apply ((<.>))+-- >>> import Data.Functor.Identity+-- >>> import Data.List.NonEmpty (NonEmpty(..))+-- >>> import qualified Data.PolyTree+-- >>> :set -XOverloadedStrings +-- | A forest of trees, represented as a functor containing either leaves (b) or subtrees.+-- The 'TreeForest' type allows for a polymorphic container type 'f', enabling different+-- forest representations (lists, vectors, etc.).+--+-- Examples:+--+-- >>> TreeForest [] :: TreeForest [] String String+-- TreeForest []+--+-- >>> TreeForest [Left "leaf1", Left "leaf2"] :: TreeForest [] String String+-- TreeForest [Left "leaf1",Left "leaf2"]+--+-- >>> TreeForest [Right (Tree "node" (TreeForest []))] :: TreeForest [] String String+-- TreeForest [Right (Tree "node" (TreeForest []))] newtype TreeForest f a b = TreeForest (f (Either b (Tree f a b))) type TreeForest' f a = TreeForest f a a -instance (TreeForest f_a4KG a_a4KH b_a4KI ~ t_a4KF) =>- Rewrapped (TreeForest f_a3dh a_a3di b_a3dj) t_a4KF+instance (TreeForest f a b ~ t) =>+ Rewrapped (TreeForest f' a' b') t instance Wrapped (TreeForest f a b) where type Unwrapped (TreeForest f a b) =@@ -95,26 +145,62 @@ liftShowsPrec = liftShowsPrec2 showsPrec showList +-- |+--+-- >>> TreeForest [Left "a"] == TreeForest [Left "a"] :: Bool+-- True+--+-- >>> TreeForest [Left "a"] == TreeForest [Left "b"] :: Bool+-- False instance (Eq a, Eq1 f, Eq b) => Eq (TreeForest f a b) where (==) = liftEq (==) +-- |+--+-- >>> compare (TreeForest [Left "a"]) (TreeForest [Left "b"]) :: Ordering+-- LT+--+-- >>> compare (TreeForest [Left "z"]) (TreeForest [Left "a"]) :: Ordering+-- GT instance (Ord a, Ord1 f, Ord b) => Ord (TreeForest f a b) where compare = liftCompare compare +-- |+--+-- >>> show (TreeForest [Left "a", makeChild "b" []]) :: String+-- "TreeForest [Left \"a\",Right (Tree \"b\" (TreeForest []))]" instance (Show a, Show1 f, Show b) => Show (TreeForest f a b) where showsPrec = liftShowsPrec showsPrec shows +-- | Map over both the node labels and leaf values in a forest.+--+-- >>> bimap (+1) (*10) (TreeForest [Left 5, makeChild 3 [Left 7]]) :: TreeForest [] Int Int+-- TreeForest [Left 50,Right (Tree 4 (TreeForest [Left 70]))] instance Functor f => Bifunctor (TreeForest f) where bimap f g (TreeForest x) = TreeForest (fmap (bimap g (bimap f g)) x) +-- | Map over the leaf values in a forest, keeping node labels unchanged.+--+-- >>> fmap (*2) (TreeForest [Left 5, Left 10]) :: TreeForest [] Int Int+-- TreeForest [Left 10,Left 20] instance Functor f => Functor (TreeForest f a) where fmap = bimap id +-- NOTE: Biapply and Biapplicative instances are NOT possible for TreeForest+-- because the recursive structure makes it impossible to correctly handle the+-- case where we have a tree of functions and a single value (or vice versa).+-- The bifunctor structure over (a, b) doesn't align with the Either-based+-- recursive forest representation.++-- | Apply instance for TreeForest using semigroup on node labels.+--+-- >>> TreeForest [Left (+1), Left (*2)] <.> TreeForest [Left 5] :: TreeForest [] String Int+-- TreeForest [Left 6,Left 10] instance (Apply f, Semigroup a) => Apply (TreeForest f a) where TreeForest x1 <.> TreeForest x2 = let combine (Left f) (Left x) =@@ -127,6 +213,13 @@ Right (tf <.> tx) in TreeForest (liftF2 combine x1 x2) +-- | Applicative instance for TreeForest using monoid on node labels.+--+-- >>> pure 42 :: TreeForest [] String Int+-- TreeForest [Left 42]+--+-- >>> TreeForest [Left (+1)] <*> TreeForest [Left 5, Left 10] :: TreeForest [] String Int+-- TreeForest [Left 6,Left 11] instance (Applicative f, Monoid a) => Applicative (TreeForest f a) where pure b = TreeForest (pure (Left b))@@ -141,69 +234,166 @@ Right (tf <*> tx) in TreeForest (liftA2 combine x1 x2) +-- | Fold over both node labels and leaf values in a forest.+--+-- >>> import Data.Monoid (Sum(..))+-- >>> bifoldMap Sum Sum (TreeForest [Left 5, makeChild 3 [Left 7]]) :: Sum Int+-- Sum {getSum = 15} instance Foldable f => Bifoldable (TreeForest f) where bifoldMap f g (TreeForest x) = foldMap (either g (bifoldMap f g)) x +-- | Bifoldable1 for non-empty forests.+--+-- >>> import Data.Semigroup (Sum(..))+-- >>> bifoldMap1 Sum Sum (TreeForest (Left 5 :| [Left 3])) :: Sum Int+-- Sum {getSum = 8} instance Foldable1 f => Bifoldable1 (TreeForest f) where bifoldMap1 f g (TreeForest x) = foldMap1 (either g (bifoldMap1 f g)) x +-- | Fold over the leaf values in a forest.+--+-- >>> foldMap (:[]) (TreeForest [Left "a", Left "b", makeChild 1 [Left "c"]]) :: [String]+-- ["a","b","c"] instance Foldable f => Foldable (TreeForest f a) where foldMap f (TreeForest x) = foldMap (either f (foldMap f)) x +-- | Foldable1 for non-empty forests.+--+-- >>> import Data.Semigroup (Sum(..))+-- >>> foldMap1 Sum (TreeForest (Left 5 :| [Left 3])) :: Sum Int+-- Sum {getSum = 8} instance Foldable1 f => Foldable1 (TreeForest f a) where foldMap1 f (TreeForest x) = foldMap1 (either f (foldMap1 f)) x +-- | Traverse both node labels and leaf values with effects.+--+-- >>> bitraverse Just Just (TreeForest [Left "x"]) :: Maybe (TreeForest [] String String)+-- Just (TreeForest [Left "x"]) instance Traversable f => Bitraversable (TreeForest f) where bitraverse f g (TreeForest x) = TreeForest <$> traverse (either (fmap Left . g) (fmap Right . bitraverse f g)) x +-- | Bitraversable1 for non-empty forests.+--+-- >>> import Data.Functor.Identity+-- >>> bitraverse1 Identity Identity (TreeForest (Left "x" :| [])) :: Identity (TreeForest NonEmpty String String)+-- Identity (TreeForest (Left "x" :| [])) instance Traversable1 f => Bitraversable1 (TreeForest f) where bitraverse1 f g (TreeForest x) = TreeForest <$> traverse1 (either (fmap Left . g) (fmap Right . bitraverse1 f g)) x +-- | Traverse the leaf values with effects.+--+-- >>> traverse Just (TreeForest [Left "x", Left "y"]) :: Maybe (TreeForest [] Int String)+-- Just (TreeForest [Left "x",Left "y"]) instance Traversable f => Traversable (TreeForest f a) where traverse f (TreeForest x) = TreeForest <$> traverse (either (fmap Left . f) (fmap Right . traverse f)) x +-- | Traversable1 for non-empty forests.+--+-- >>> import Data.Functor.Identity+-- >>> traverse1 Identity (TreeForest (Left "x" :| [])) :: Identity (TreeForest NonEmpty Int String)+-- Identity (TreeForest (Left "x" :| [])) instance Traversable1 f => Traversable1 (TreeForest f a) where traverse1 f (TreeForest x) = TreeForest <$> traverse1 (either (fmap Left . f) (fmap Right . traverse1 f)) x -class HasTreeForest x f a b | x -> f a b where+-- | Read-only access to a tree forest structure via a 'Getter'.+class GetTreeForest x f a b | x -> f a b where+ -- | Extract the tree forest from a structure.+ getTreeForest ::+ Getter x (TreeForest f a b)++-- |+--+-- >>> view getTreeForest (TreeForest [Left "a", makeChild "b" []]) == TreeForest [Left "a", Right (Tree "b" (TreeForest []))]+-- True+instance GetTreeForest (TreeForest f a b) f a b where+ getTreeForest =+ to id++-- | Read-write access to a tree forest structure via a 'Lens'.+-- This extends 'GetTreeForest' to allow modification.+class GetTreeForest x f a b => HasTreeForest x f a b | x -> f a b where+ -- | Access the tree forest with read-write capability. treeForest :: Lens' x (TreeForest f a b) +-- |+--+-- >>> view treeForest (TreeForest []) :: TreeForest [] String String+-- TreeForest [] instance HasTreeForest (TreeForest f a b) f a b where treeForest = id -class AsTreeForest x f a b | x -> f a b where+-- | Construction-only access to a tree forest via a 'Review'.+class ReviewTreeForest x f a b | x -> f a b where+ -- | Construct a value from a tree forest.+ reviewTreeForest ::+ Review x (TreeForest f a b)++-- |+--+-- >>> review reviewTreeForest (TreeForest [Left "x"]) :: TreeForest [] String String+-- TreeForest [Left "x"]+instance ReviewTreeForest (TreeForest f a b) f a b where+ reviewTreeForest =+ unto id++-- | Full prism access to a tree forest structure.+-- This extends 'ReviewTreeForest' to allow both construction and pattern matching.+class ReviewTreeForest x f a b => AsTreeForest x f a b | x -> f a b where+ -- | Access the tree forest as a prism (construct or pattern match). _TreeForest :: Prism' x (TreeForest f a b) +-- |+--+-- >>> preview _TreeForest (TreeForest [Left "y"]) :: Maybe (TreeForest [] String String)+-- Just (TreeForest [Left "y"]) instance AsTreeForest (TreeForest f a b) f a b where _TreeForest = id +-- | A polymorphic rose tree with different types for node labels (a) and leaf values (b).+-- The container type 'f' allows for different representations of child forests.+--+-- Examples:+--+-- >>> Tree "root" (TreeForest []) :: TreeList String String+-- Tree "root" (TreeForest [])+--+-- >>> Tree "root" (TreeForest [Left "leaf1", Left "leaf2"]) :: TreeList String String+-- Tree "root" (TreeForest [Left "leaf1",Left "leaf2"])+--+-- >>> Tree "root" (TreeForest [makeChild "child" [Left "leaf"]]) :: TreeList String String+-- Tree "root" (TreeForest [Right (Tree "child" (TreeForest [Left "leaf"]))]) data Tree f a b = Tree a (TreeForest f a b) +-- | A tree where node labels and leaf values have the same type. type Tree' f a = Tree f a a +-- | A tree using lists for the forest container. type TreeList a b = Tree [] a b +-- | A list-based tree where nodes and leaves have the same type. type TreeList' a = TreeList a a +-- | A tree with a single child (using Identity). type Tree1 a b = Tree Identity a b +-- | A single-child tree where nodes and leaves have the same type. type Tree1' a = Tree1 a a @@ -239,26 +429,57 @@ liftShowsPrec = liftShowsPrec2 showsPrec showList +-- |+--+-- >>> Tree "a" (TreeForest []) == Tree "a" (TreeForest []) :: Bool+-- True+--+-- >>> Tree "a" (TreeForest [Left 1]) == Tree "a" (TreeForest [Left 2]) :: Bool+-- False instance (Eq a, Eq1 f, Eq b) => Eq (Tree f a b) where (==) = liftEq (==) +-- |+--+-- >>> compare (Tree "a" (TreeForest [])) (Tree "b" (TreeForest [])) :: Ordering+-- LT instance (Ord a, Ord1 f, Ord b) => Ord (Tree f a b) where compare = liftCompare compare +-- |+--+-- >>> show (Tree "root" (TreeForest [Left "x"])) :: String+-- "Tree \"root\" (TreeForest [Left \"x\"])" instance (Show a, Show1 f, Show b) => Show (Tree f a b) where showsPrec = liftShowsPrec showsPrec shows +-- | Map over both node labels and leaf values.+--+-- >>> bimap (+1) (*10) (Tree 5 (TreeForest [Left 3])) :: TreeList Int Int+-- Tree 6 (TreeForest [Left 30]) instance Functor f => Bifunctor (Tree f) where bimap f g (Tree a t) = Tree (f a) (bimap f g t) +-- | Map over leaf values, keeping node labels unchanged.+--+-- >>> fmap (*2) (Tree "root" (TreeForest [Left 5, Left 10])) :: TreeList String Int+-- Tree "root" (TreeForest [Left 10,Left 20]) instance Functor f => Functor (Tree f a) where fmap = bimap id +-- NOTE: Biapply and Biapplicative instances are NOT possible for Tree+-- because the underlying TreeForest cannot support these instances due to+-- the recursive Either-based structure. See the note on TreeForest above.++-- | Apply with semigroup combination of node labels.+--+-- >>> Tree "a" (TreeForest [Left (+1)]) <.> Tree "b" (TreeForest [Left 5]) :: TreeList String Int+-- Tree "ab" (TreeForest [Left 6]) instance (Apply f, Semigroup a) => Apply (Tree f a) where Tree a1 t1 <.> Tree a2 t2 = Tree (a1 <> a2) (t1 <.> t2)@@ -279,38 +500,79 @@ Tree a1 t1 <*> Tree a2 t2 = Tree (a1 <> a2) (t1 <*> t2) +-- | Fold over both node labels and leaf values.+--+-- >>> import Data.Monoid (Sum(..))+-- >>> bifoldMap Sum Sum (Tree 1 (TreeForest [Left 5, makeChild 3 []])) :: Sum Int+-- Sum {getSum = 9} instance Foldable f => Bifoldable (Tree f) where bifoldMap f g (Tree a t) = f a <> bifoldMap f g t +-- | Bifoldable1 for trees with non-empty forests.+--+-- >>> import Data.Semigroup (Sum(..))+-- >>> bifoldMap1 Sum Sum (Tree 1 (TreeForest (Left 5 :| []))) :: Sum Int+-- Sum {getSum = 6} instance Foldable1 f => Bifoldable1 (Tree f) where bifoldMap1 f g (Tree a t) = f a <> bifoldMap1 f g t +-- | Fold over leaf values only (ignores node labels).+--+-- >>> foldMap (:[]) (Tree "root" (TreeForest [Left "a", Left "b"])) :: [String]+-- ["a","b"] instance Foldable f => Foldable (Tree f a) where foldMap f (Tree _ t) = foldMap f t +-- | Foldable1 for trees with non-empty forests.+--+-- >>> import Data.Semigroup (Sum(..))+-- >>> foldMap1 Sum (Tree "root" (TreeForest (Left 5 :| [Left 10]))) :: Sum Int+-- Sum {getSum = 15} instance Foldable1 f => Foldable1 (Tree f a) where foldMap1 f (Tree _ t) = foldMap1 f t +-- | Traverse both node labels and leaf values with effects.+--+-- >>> bitraverse Just Just (Tree "a" (TreeForest [Left "b"])) :: Maybe (TreeList String String)+-- Just (Tree "a" (TreeForest [Left "b"])) instance Traversable f => Bitraversable (Tree f) where bitraverse f g (Tree a t) = Tree <$> f a <*> bitraverse f g t +-- | Bitraversable1 for trees with non-empty forests.+--+-- >>> import Data.Functor.Identity+-- >>> bitraverse1 Identity Identity (Tree "a" (TreeForest (Left "b" :| []))) :: Identity (Tree NonEmpty String String)+-- Identity (Tree "a" (TreeForest (Left "b" :| []))) instance Traversable1 f => Bitraversable1 (Tree f) where bitraverse1 f g (Tree a t) = Tree <$> f a <.> bitraverse1 f g t +-- | Traverse leaf values with effects.+--+-- >>> traverse Just (Tree "root" (TreeForest [Left "x"])) :: Maybe (TreeList String String)+-- Just (Tree "root" (TreeForest [Left "x"])) instance Traversable f => Traversable (Tree f a) where traverse f (Tree a t) = Tree a <$> traverse f t +-- | Traversable1 for trees with non-empty forests.+--+-- >>> import Data.Functor.Identity+-- >>> traverse1 Identity (Tree "root" (TreeForest (Left "x" :| []))) :: Identity (Tree NonEmpty String String)+-- Identity (Tree "root" (TreeForest (Left "x" :| []))) instance Traversable1 f => Traversable1 (Tree f a) where traverse1 f (Tree a t) = Tree a <$> traverse1 f t +-- | Plated instance for recursive tree traversal.+--+-- >>> transform (\(Tree a f) -> Tree (a <> "!") f) (Tree "a" (TreeForest [makeChild "b" []])) :: TreeList String String+-- Tree "a!" (TreeForest [Right (Tree "b!" (TreeForest []))]) instance Traversable f => Plated (Tree f a b) where plate f (Tree a (TreeForest x)) = Tree a . TreeForest <$> traverse@@ -319,6 +581,13 @@ (fmap Right . f) ) x +-- | Lens into a tree's forest.+--+-- >>> view treeForest' (Tree "a" (TreeForest [Left "x"])) :: TreeForest [] String String+-- TreeForest [Left "x"]+--+-- >>> set treeForest' (TreeForest [Left "y"]) (Tree "a" (TreeForest [Left "x"])) :: TreeList String String+-- Tree "a" (TreeForest [Left "y"]) treeForest' :: Lens (Tree f a b)@@ -328,6 +597,10 @@ treeForest' f (Tree a t) = fmap (Tree a) (f t) +-- | Traversal over the immediate children and leaves of a tree.+--+-- >>> toListOf treeSubForest (Tree "root" (TreeForest [Left "x", makeChild "c" []])) :: [Either String (TreeList String String)]+-- [Left "x",Right (Tree "c" (TreeForest []))] treeSubForest :: Traversable f => Traversal@@ -338,6 +611,13 @@ treeSubForest = treeForest' . _Wrapped . traverse +-- | Traversal over all immediate leaves in a tree (not recursive).+--+-- >>> toListOf treeLeaves (Tree "root" (TreeForest [Left "x", Left "y"])) :: [String]+-- ["x","y"]+--+-- >>> over treeLeaves (*2) (Tree "root" (TreeForest [Left 5, Left 10])) :: TreeList String Int+-- Tree "root" (TreeForest [Left 10,Left 20]) treeLeaves :: Traversable f => Traversal'@@ -346,6 +626,10 @@ treeLeaves = treeSubForest . _Left +-- | Traversal over the immediate child trees.+--+-- >>> lengthOf treeForestChildren (Tree "root" (TreeForest [Left "x", makeChild "c1" [], makeChild "c2" []]))+-- 2 treeForestChildren :: Traversable f => Traversal'@@ -354,10 +638,42 @@ treeForestChildren = treeSubForest . _Right -class HasTree x f a b | x -> f a b where+-- | Read-only access to a tree structure via a 'Getter'.+-- This is the most general class, allowing types to expose a tree view+-- without necessarily allowing modification.+class GetTree x f a b | x -> f a b where+ -- | Extract the tree from a structure.+ getTree ::+ Getter x (Tree f a b)+ {-# INLINE getTreeLabel #-}+ -- | Extract just the tree's label.+ getTreeLabel ::+ Getter x a+ getTreeLabel =+ getTree . getTreeLabel++-- |+--+-- >>> view getTreeLabel (Tree "a" (TreeForest []))+-- "a"+--+-- >>> view getTree (Tree "a" (TreeForest [])) == Tree "a" (TreeForest [])+-- True+instance GetTree (Tree f a b) f a b where+ getTree =+ to id+ {-# INLINE getTreeLabel #-}+ getTreeLabel =+ to (\(Tree a _) -> a)++-- | Read-write access to a tree structure via a 'Lens'.+-- This extends 'GetTree' to allow modification.+class GetTree x f a b => HasTree x f a b | x -> f a b where+ -- | Access the tree with read-write capability. tree :: Lens' x (Tree f a b) {-# INLINE treeLabel #-}+ -- | Access the tree's label with read-write capability. treeLabel :: Lens' x a treeLabel =@@ -368,6 +684,9 @@ -- >>> view treeLabel (Tree "a" (TreeForest [])) -- "a" --+-- >>> set treeLabel "z" (Tree "a" (TreeForest [])) :: TreeList String String+-- Tree "z" (TreeForest [])+-- -- >>> view treeForest (Tree "a" (TreeForest [])) -- TreeForest [] --@@ -380,14 +699,51 @@ treeLabel f (Tree a t) = fmap (`Tree` t) (f a) +-- |+--+-- >>> view getTreeForest (Tree "root" (TreeForest [Left "a"])) :: TreeForest [] String String+-- TreeForest [Left "a"]+instance GetTreeForest (Tree f a b) f a b where+ getTreeForest =+ to (\(Tree _ forest) -> forest)++-- |+--+-- >>> view treeForest (Tree "root" (TreeForest [Left "a"])) :: TreeForest [] String String+-- TreeForest [Left "a"]+--+-- >>> set treeForest (TreeForest [Left "b"]) (Tree "root" (TreeForest [Left "a"])) :: TreeList String String+-- Tree "root" (TreeForest [Left "b"]) instance HasTreeForest (Tree f a b) f a b where treeForest = treeForest' -class AsTree x f a b | x -> f a b where+-- | Construction-only access to a tree via a 'Review'.+-- This allows building a type from a tree.+class ReviewTree x f a b | x -> f a b where+ -- | Construct a value from a tree.+ reviewTree ::+ Review x (Tree f a b)++-- |+--+-- >>> review reviewTree (Tree "hello" (TreeForest [])) :: TreeList String String+-- Tree "hello" (TreeForest [])+instance ReviewTree (Tree f a b) f a b where+ reviewTree =+ unto id++-- | Full prism access to a tree structure.+-- This extends 'ReviewTree' to allow both construction and pattern matching.+class ReviewTree x f a b => AsTree x f a b | x -> f a b where+ -- | Access the tree as a prism (construct or pattern match). _Tree :: Prism' x (Tree f a b) +-- |+--+-- >>> preview _Tree (Tree "test" (TreeForest [])) :: Maybe (TreeList String String)+-- Just (Tree "test" (TreeForest [])) instance AsTree (Tree f a b) f a b where _Tree = id@@ -452,6 +808,23 @@ -- | --+-- >>> makeTree 1 []+-- Tree 1 (TreeForest [])+--+-- >>> makeTree 1 [Left "a"]+-- Tree 1 (TreeForest [Left "a"])+--+-- >>> makeTree 1 [Left "a", Right (makeTree 2 [])]+-- Tree 1 (TreeForest [Left "a",Right (Tree 2 (TreeForest []))])+makeTree ::+ a+ -> f (Either b (Tree f a b))+ -> Tree f a b+makeTree a t =+ Tree a (TreeForest t)++-- |+-- -- >>> makeChild 1 [] -- Right (Tree 1 (TreeForest [])) --@@ -465,7 +838,7 @@ -> f (Either b (Tree f a b)) -> Either x (Tree f a b) makeChild a t =- Right (Tree a (TreeForest t))+ Right (makeTree a t) -- | --@@ -502,6 +875,100 @@ -> Tree f a b makeChildren a cs = Tree a (TreeForest (Right <$> cs))++-- |+--+-- >>> singleton "root" :: TreeList String String+-- Tree "root" (TreeForest [])+singleton ::+ Monoid (f (Either b (Tree f a b))) =>+ a+ -> Tree f a b+singleton a =+ Tree a (TreeForest mempty)++-- |+--+-- >>> unfoldTree (\n -> (n, if n < 3 then [Left (n * 10), Right (n + 1)] else [])) 1 :: TreeList Int Int+-- Tree 1 (TreeForest [Left 10,Right (Tree 2 (TreeForest [Left 20,Right (Tree 3 (TreeForest []))]))])+unfoldTree ::+ Functor f =>+ (a -> (a, f (Either b a)))+ -> a+ -> Tree f a b+unfoldTree f seed =+ let (label, forest) = f seed+ in Tree label (TreeForest (fmap (fmap (unfoldTree f)) forest))++-- |+--+-- >>> unfoldTreeM (\n -> pure (n, if n < 3 then [Left (n * 10), Right (n + 1)] else [])) 1 :: Maybe (TreeList Int Int)+-- Just (Tree 1 (TreeForest [Left 10,Right (Tree 2 (TreeForest [Left 20,Right (Tree 3 (TreeForest []))]))]))+unfoldTreeM ::+ (Monad m, Traversable f) =>+ (a -> m (a, f (Either b a)))+ -> a+ -> m (Tree f a b)+unfoldTreeM f seed = do+ (label, forest) <- f seed+ forest' <- traverse (either (pure . Left) (fmap Right . unfoldTreeM f)) forest+ pure (Tree label (TreeForest forest'))++-- |+--+-- >>> pruneLeaves (> 2) (Tree 1 (TreeForest [Left 1, Left 3, makeChild 2 [Left 2, Left 4]])) :: TreeList Int Int+-- Tree 1 (TreeForest [Left 3,Right (Tree 2 (TreeForest [Left 4]))])+pruneLeaves ::+ (Traversable f, Applicative f, Monoid (f (Either b (Tree f a b)))) =>+ (b -> Bool)+ -> Tree f a b+ -> Tree f a b+pruneLeaves p (Tree a (TreeForest forest)) =+ Tree a (TreeForest (foldMap go forest))+ where+ go (Left b) = if p b then pure (Left b) else mempty+ go (Right t) = pure (Right (pruneLeaves p t))++-- |+--+-- >>> countNodes (Tree 1 (TreeForest [Left 2, makeChild 3 [Left 4], makeChild 5 []])) :: Int+-- 3+countNodes ::+ Foldable f =>+ Tree f a b+ -> Int+countNodes (Tree _ (TreeForest forest)) =+ 1 + getSum (foldMap (either (const (Sum 0)) (Sum . countNodes)) forest)++-- |+--+-- >>> countLeaves (Tree 1 (TreeForest [Left 2, makeChild 3 [Left 4], makeChild 5 []])) :: Int+-- 2+countLeaves ::+ Foldable f =>+ Tree f a b+ -> Int+countLeaves (Tree _ (TreeForest forest)) =+ getSum (foldMap (either (const (Sum 1)) (Sum . countLeaves)) forest)++-- | Group tree elements by their depth level.+--+-- >>> Data.PolyTree.levels (Tree 1 (TreeForest [Left 2, makeChild 3 [], Left 7])) :: [[Either Int Int]]+-- [[Left 1],[Right 2],[Right 7],[Left 3]]+levels ::+ Foldable f =>+ Tree f a b+ -> [[Either a b]]+levels t =+ case bfs t of+ root :| rest -> groupByLevel [root] rest+ where+ groupByLevel acc [] = [acc]+ groupByLevel acc xs =+ let (level, remaining) = splitAt (length acc) xs+ in if null level+ then [acc]+ else acc : groupByLevel level remaining -- | --
+ test/Main.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}++module Main (main) where++import System.Exit (exitWith)+import System.Process (rawSystem)++main :: IO ()+main =+ exitWith+ =<< rawSystem+ "cabal"+ [ "repl",+ "--with-compiler=doctest",+ "--repl-options=-w",+ "--repl-options=-Wdefault",+ "lib:polytree"+ ]