polytree 0.0.1 → 0.0.2

raw patch · 3 files changed

+380/−12 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• polytree.cabal +1/−1
• src/Data/PolyTree.hs +375/−11

@@ -1,3 +1,7 @@+0.0.2++* Add more optics and functions+ 0.0.1  * This change log starts

@@ -1,5 +1,5 @@ name:                 polytree-version:              0.0.1+version:              0.0.2 synopsis:             A polymorphic rose-tree description:          A rose-tree which has different data in the nodes and leaves license:              BSD3

@@ -5,13 +5,45 @@ module Data.PolyTree where  import Control.Lens-import Data.Bifoldable-import Data.Bitraversable+    ( preview,+      iso,+      _Right,+      prism,+      prism',+      Plated(..),+      Field1(_1),+      Field2(_2),+      Iso,+      Lens,+      Lens',+      Prism,+      Prism',+      Traversal )+import Data.Bifoldable ( Bifoldable(bifoldMap) )+import Data.Bifunctor ( Bifunctor(bimap) )+import Data.Bitraversable ( Bitraversable(..) )+import Data.Functor.Apply ( Apply((<.>)) )+import Data.Functor.Bind ( Bind((>>-)) ) import Data.Functor.Classes-import Data.List.NonEmpty+    ( showsBinaryWith,+      showsUnaryWith,+      Eq1(..),+      Eq2(..),+      Ord1(..),+      Ord2(..),+      Show1(liftShowsPrec),+      Show2(..) )+import Data.Functor.Identity ( Identity(..) )+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 qualified Data.Tree as Tree-import Data.Void+import Data.Void ( Void, absurd ) +-- $setup+-- >>> import Control.Lens+ data Tree f a b =   Leaf b   | Node a (f (Tree f a b))@@ -22,9 +54,15 @@ type Tree0 a b =   Tree [] a b +type Tree0' a =+  Tree0 a a+ type Tree1 a b =-  Tree NonEmpty a b+  Tree Identity a b +type Tree1' a =+  Tree1 a a+ instance Eq1 f => Eq2 (Tree f) where   liftEq2 _ g (Leaf b1) (Leaf b2) =     g b1 b2@@ -75,41 +113,232 @@   show x =     liftShowsPrec showsPrec shows 0 x "" +-- |+--+-- >>> bimap (+1) (+2) (Leaf 10) :: Tree' [] Int+-- Leaf 12+--+-- >>> bimap (+1) (+2) (Node 20 [Leaf 10]) :: Tree' [] Int+-- Node 21 [Leaf 12]+--+-- >>> bimap (+1) (+2) (Node 20 [Node 30 [Leaf 10], Leaf 40]) :: Tree' [] Int+-- Node 21 [Node 31 [Leaf 12],Leaf 42] instance Functor f => Bifunctor (Tree f) where   bimap _ g (Leaf b) =     Leaf (g b)   bimap f g (Node a t) =     Node (f a) (fmap (bimap f g) t) +-- |+--+-- >>> fmap (+1) (Leaf 10) :: Tree' [] Int+-- Leaf 11+--+-- >>> fmap (+1) (Node 20 [Leaf 10]) :: Tree' [] Int+-- Node 20 [Leaf 11]+--+-- >>> fmap (+1) (Node 20 [Node 30 [Leaf 10], Leaf 40]) :: Tree' [] Int+-- Node 20 [Node 30 [Leaf 11],Leaf 41] instance Functor f => Functor (Tree f a) where   fmap =     bimap id +-- >>> Leaf (+1) <.> Leaf 10 :: Tree' [] Int+-- Leaf 11+--+-- >>> Leaf (+1) <.> Node 10 [] :: Tree' [] Int+-- Node 10 []+--+-- >>> Node 20 [] <.> Node 10 [] :: Tree' [] Int+-- Node 20 []+--+-- >>> Node 20 [] <.> Leaf 10 :: Tree' [] Int+-- Node 20 []+--+-- >>> Leaf (+1) <.> Node 20 [Leaf 10] :: Tree' [] Int+-- Node 20 [Leaf 11]+--+-- >>> Node 10 [] <.> Node 20 [Leaf 10] :: Tree' [] Int+-- Node 10 []+instance Functor f => Apply (Tree f a) where+  Leaf f <.> t =+    fmap f t+  Node a fs <.> t =+    Node a (fmap (<*> t) fs)++-- |+--+-- >>> pure 10 :: Tree' [] Int+-- Leaf 10+instance Functor f => Applicative (Tree f a) where+  pure =+    Leaf+  (<*>) =+    (<.>)++-- |+--+-- >>> Leaf 10 >>- \n -> Leaf (n + 1) :: Tree' [] Int+-- Leaf 11+--+-- >>> Leaf 10 >>- \n -> Node 20 [] :: Tree' [] Int+-- Node 20 []+--+-- >>> Leaf 10 >>- \n -> Node 20 [Leaf 30] :: Tree' [] Int+-- Node 20 [Leaf 30]+--+-- >>> Node 10 [] >>- Leaf+-- Node 10 []+--+-- >>> Node 10 [] >>- \n -> Node 20 [Leaf n] :: Tree' [] Int+-- Node 10 []+instance Functor f => Bind (Tree f a) where+  Leaf x >>- k =+    k x+  Node a ts >>- k =+    Node a (fmap (>>= k) ts)++instance Functor f => Monad (Tree f a) where+  (>>=) =+    (>>-)++-- |+--+-- >>> bifoldMap1 reverse (<> "DEF") (Leaf "ABC" :: Tree1' String)+-- "ABCDEF"+--+-- >>> bifoldMap1 reverse (<> "DEF") (_Node1 # ("ABC", Leaf "DEF"))+-- "CBADEFDEF"+--+-- >>> bifoldMap1 reverse (<> "DEF") (_Node1 # ("ABC", _Node1 # ("DEF", Leaf "GHI")))+-- "CBAFEDGHIDEF"+instance Foldable1 f => Bifoldable1 (Tree f) where+  bifoldMap1 _ g (Leaf b) =+    g b+  bifoldMap1 f g (Node a t) =+    f a <> foldMap1 (bifoldMap1 f g) t++-- |+--+-- >>> bifoldMap reverse (<> "DEF") (Leaf "ABC" :: Tree0' String)+-- "ABCDEF"+--+-- >>> bifoldMap reverse (<> "DEF") (Node "ABC" [Leaf "DEF"])+-- "CBADEFDEF"+--+-- >>> bifoldMap reverse (<> "DEF") (Node "ABC" [Node "DEF" [Leaf "GHI"]])+-- "CBAFEDGHIDEF" instance Foldable f => Bifoldable (Tree f) where   bifoldMap _ g (Leaf b) =     g b   bifoldMap f g (Node a t) =     f a <> foldMap (bifoldMap f g) t +-- |+--+-- >>> foldMap1 reverse (Leaf "ABC" :: Tree1' String)+-- "CBA"+--+-- >>> foldMap1 reverse (_Node1 # ("ABC", Leaf "DEF"))+-- "FED"+--+-- >>> foldMap1 reverse (_Node1 # ("ABC", _Node1 # ("DEF", Leaf "GHI")))+-- "IHG"+instance Foldable1 f => Foldable1 (Tree f a) where+  foldMap1 g (Leaf b) =+    g b+  foldMap1 g (Node _ ts) =+    foldMap1 (foldMap1 g) ts++-- |+--+-- >>> foldMap reverse (Leaf "ABC" :: Tree1' String)+-- "CBA"+--+-- >>> foldMap reverse (Node "ABC" [Leaf "DEF"])+-- "FED"+--+-- >>> foldMap reverse (Node "ABC" [Node "DEF" [Leaf "GHI"]])+-- "IHG" instance Foldable f => Foldable (Tree f a) where-  foldMap =-    bifoldMap (pure mempty)+  foldMap g (Leaf b) =+    g b+  foldMap g (Node _ ts) =+    foldMap (foldMap g) ts +-- |+--+-- >>> bitraverse1 (\x -> [x, reverse x]) (\x -> [x, x <> "DEF"]) (Leaf "ABC" :: Tree1' String)+-- [Leaf "ABC",Leaf "ABCDEF"]+--+-- >>> bitraverse1 (\x -> [x, reverse x]) (\x -> [x, x <> "DEF"]) (Node "ABC" (Identity (Leaf "XYZ")) :: Tree1' String)+-- [Node "ABC" (Identity (Leaf "XYZ")),Node "ABC" (Identity (Leaf "XYZDEF")),Node "CBA" (Identity (Leaf "XYZ")),Node "CBA" (Identity (Leaf "XYZDEF"))]+instance Traversable1 f => Bitraversable1 (Tree f) where+  bitraverse1 _ g (Leaf b) =+    Leaf <$> g b+  bitraverse1 f g (Node a ts) =+    Node <$> f a <.> traverse1 (bitraverse1 f g) ts++-- |+--+-- >>> bitraverse (\x -> [x, reverse x]) (\x -> [x, x <> "DEF"]) (Leaf "ABC" :: Tree1' String)+-- [Leaf "ABC",Leaf "ABCDEF"]+--+-- >>> bitraverse (\x -> [x, reverse x]) (\x -> [x, x <> "DEF"]) (Node "ABC" (Identity (Leaf "XYZ")) :: Tree1' String)+-- [Node "ABC" (Identity (Leaf "XYZ")),Node "ABC" (Identity (Leaf "XYZDEF")),Node "CBA" (Identity (Leaf "XYZ")),Node "CBA" (Identity (Leaf "XYZDEF"))] instance Traversable f => Bitraversable (Tree f) where   bitraverse _ g (Leaf b) =     Leaf <$> g b   bitraverse f g (Node a ts) =     Node <$> f a <*> traverse (bitraverse f g) ts +-- |+--+-- >>> traverse1 (\x -> [x, reverse x]) (Leaf "ABC" :: Tree1' String)+-- [Leaf "ABC",Leaf "CBA"]+--+-- >>> traverse1 (\x -> [x, reverse x]) (Node "ABC" (Identity (Leaf "XYZ")) :: Tree1' String)+-- [Node "ABC" (Identity (Leaf "XYZ")),Node "ABC" (Identity (Leaf "ZYX"))]+instance Traversable1 f => Traversable1 (Tree f a) where+  traverse1 f (Leaf b) =+    Leaf <$> f b+  traverse1 f (Node a ts) =+    Node a <$> traverse1 (traverse1 f) ts++-- |+--+-- >>> traverse (\x -> [x, reverse x]) (Leaf "ABC" :: Tree1' String)+-- [Leaf "ABC",Leaf "CBA"]+--+-- >>> traverse (\x -> [x, reverse x]) (Node "ABC" (Identity (Leaf "XYZ")) :: Tree1' String)+-- [Node "ABC" (Identity (Leaf "XYZ")),Node "ABC" (Identity (Leaf "ZYX"))] instance Traversable f => Traversable (Tree f a) where-  traverse =-    bitraverse pure+  traverse f (Leaf b) =+    Leaf <$> f b+  traverse f (Node a ts) =+    Node a <$> traverse (traverse f) ts +-- |+--+-- >>> toListOf plate (Leaf 1 :: Tree0' Int)+-- []+--+-- >>> toListOf plate (Node 1 [] :: Tree0' Int)+-- []+--+-- >>> toListOf plate (Node 1 [Leaf 2] :: Tree0' Int)+-- [Leaf 2]+--+-- >>> > toListOf plate (Node 1 [Leaf 2, Leaf 3, Node 4 []] :: Tree0' Int)+-- [Leaf 2,Leaf 3,Node 4 []]+--+-- >>> toListOf plate (Node 1 [Leaf 2, Leaf 3, Node 4 [Leaf 5]] :: Tree0' Int)+-- [Leaf 2,Leaf 3,Node 4 [Leaf 5]] instance Traversable f => Plated (Tree f a b) where   plate _ (Leaf b) =     pure (Leaf b)   plate f (Node a ts) =-    Node a <$> traverse (plate f) ts+    Node a <$> traverse f ts  foldTree ::   (b -> x)@@ -119,13 +348,39 @@   l b foldTree _ n (Node a t) =   n a t-  ++-- |+--+-- >>> treeValue (Leaf 1 :: Tree' [] Int)+-- Right 1+--+-- >>> treeValue (Node 1 [] :: Tree' [] Int)+-- Left 1+--+-- >>> treeValue (Node 1 [Leaf 2] :: Tree' [] Int)+-- Left 1+--+-- >>> treeValue (Node 1 [Node 2 []] :: Tree' [] Int)+-- Left 1 treeValue ::   Tree f a b   -> Either a b treeValue =   foldTree Right (pure . Left) +-- |+--+-- >>> treeChildren (Leaf 1 :: Tree' [] Int)+-- Left 1+--+-- >>> treeChildren (Node 1 [] :: Tree' [] Int)+-- Right []+--+-- >>> treeChildren (Node 1 [Leaf 2] :: Tree' [] Int)+-- Right [Leaf 2]+--+-- >>> treeChildren (Node 1 [Leaf 2, Node 3 []] :: Tree' [] Int)+-- Right [Leaf 2,Node 3 []] treeChildren ::   Tree f a b   -> Either b (f (Tree f a b))@@ -207,6 +462,70 @@         Leaf b ->           Left (Leaf b)) +-- |+--+-- >>> toListOf _Node0 (Leaf "ABC" :: Tree0' String)+-- []+--+-- >>> toListOf _Node0 (Node "ABC" [] :: Tree0' String)+-- []+--+-- >>> toListOf _Node0 (Node "ABC" [Leaf "DEF"] :: Tree0' String)+-- [("ABC",Leaf "DEF")]+--+-- >>> toListOf _Node0 (Node "ABC" [Leaf "DEF", Leaf "GHI"] :: Tree0' String)+-- [("ABC",Leaf "DEF"),("ABC",Leaf "GHI")]+--+-- >>> toListOf _Node0 (Node "ABC" [Leaf "DEF", Node "GHI" []] :: Tree0' String)+-- [("ABC",Leaf "DEF"),("ABC",Node "GHI" [])]+_Node0 ::+  Monoid a' =>+  Traversal+    (Tree0 a b)+    (Tree0 a' b)+    (a, Tree0 a b)+    (a', Tree0 a' b)+_Node0 _ (Leaf b) =+  pure (Leaf b)+_Node0 f (Node a t) =+  (Node <$> (mconcat . map fst) <*> map snd) <$> traverse (\x -> f (a, x)) t++-- |+--+-- >>> preview _Node1 (Leaf 1 :: Tree1' Int)+-- Nothing+--+-- >>> preview _Node1 (Node 1 (Identity (Leaf 2)) :: Tree1' Int)+-- Just (1,Leaf 2)+_Node1 ::+  Prism+    (Tree1 a b)+    (Tree1 a' b)+    (a, Tree1 a b)+    (a', Tree1 a' b)+_Node1 =+  prism+    (\(a, t) -> Node a (Identity t))+    (\case+        Node a t ->+          Right (a, runIdentity t)+        Leaf b ->+          Left (Leaf b)+    )++-- |+--+-- >>> view treeIso (Leaf 1 :: Tree' [] Int)+-- (1,Nothing)+--+-- >>> view treeIso (Node 1 [] :: Tree' [] Int)+-- (1,Just [])+--+-- >>> view treeIso (Node 1 [Leaf 2] :: Tree' [] Int)+-- (1,Just [Leaf 2])+--+-- >>> view treeIso (Node 1 [Leaf 2, Node 3 []] :: Tree' [] Int)+-- (1,Just [Leaf 2,Node 3 []]) treeIso ::   Iso     (Tree' f a)@@ -218,6 +537,19 @@     (foldTree (, Nothing) (\a t -> (a, Just t)))     (\(a, t) -> maybe (Leaf a) (Node a) t) +-- |+--+-- >>> view treeValue' (Leaf 1 :: Tree' [] Int)+-- 1+--+-- >>> view treeValue' (Node 1 [] :: Tree' [] Int)+-- 1+--+-- >>> view treeValue' (Node 1 [Leaf 2] :: Tree' [] Int)+-- 1+--+-- >>> view treeValue' (Node 1 [Leaf 2, Node 3 []] :: Tree' [] Int)+-- 1 treeValue' ::   Lens'     (Tree' f a)@@ -225,6 +557,22 @@ treeValue' =   treeIso . _1 +-- |+--+-- >>> view treeChildren' (Leaf 1 :: Tree' [] Int)+-- Nothing+--+-- >>> view treeChildren' (Node 1 [] :: Tree' [] Int)+-- Just []+--+-- >>> view treeChildren' (Node 1 [Leaf 2, Leaf 3] :: Tree' [] Int)+-- Just [Leaf 2,Leaf 3]+--+-- >>> view treeChildren' (Node 1 [Leaf 2, Leaf 3, Node 4 []] :: Tree' [] Int)+-- Just [Leaf 2,Leaf 3,Node 4 []]+--+-- >>> view treeChildren' (Node 1 [Leaf 2, Leaf 3, Node 4 [Node 5 []]] :: Tree' [] Int)+-- Just [Leaf 2,Leaf 3,Node 4 [Node 5 []]] treeChildren' ::   Lens     (Tree' f a)@@ -234,6 +582,22 @@ treeChildren' =   treeIso . _2 +-- |+--+-- >>> view baseTree (Node 1 [])+-- Node {rootLabel = 1, subForest = []}+--+-- >>> view baseTree (Node 1 [Node 2 []])+-- Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}+--+-- >>> view baseTree (Node 1 [Node 2 [], Node 3 [], Node 4 []])+-- Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []},Node {rootLabel = 3, subForest = []},Node {rootLabel = 4, subForest = []}]}+--+-- >>> review baseTree (Tree.Node 1 [])+-- Node 1 []+--+-- >>> review baseTree (Tree.Node 1 [Tree.Node 2 []])+-- Node 1 [Node 2 []] baseTree ::   Iso     (Tree0 a Void)