polytree-0.0.8: src/Data/PolyTree.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Data.PolyTree where
import Control.Applicative ( Applicative(liftA2), Alternative(empty), asum )
import Control.Lens
( preview,
iso,
_Right,
prism,
prism',
review,
Plated(..),
Field1(_1),
Field2(_2),
Iso,
Lens,
Lens',
Prism,
Prism',
Traversal,
Traversal' )
import Control.Monad.Free ( Free(..) )
import qualified Control.Monad.Trans.Free as FreeT(Free, FreeF(..), free, runFree)
import Data.Bifoldable ( Bifoldable(bifoldMap) )
import Data.Bifunctor ( Bifunctor(bimap) )
import Data.Bitraversable ( Bitraversable(..) )
import Data.Foldable ( traverse_ )
import Data.Functor ( void )
import Data.Functor.Apply ( Apply((<.>)) )
import Data.Functor.Bind ( Bind((>>-)) )
import Data.Functor.Classes
( showsBinaryWith,
showsUnaryWith,
Eq1(..),
Eq2(..),
Ord1(..),
Ord2(..),
Show1(liftShowsPrec),
Show2(..) )
import Data.Functor.Compose ( Compose(..) )
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 ( Void, absurd )
-- $setup
-- >>> import Control.Lens
data Tree f a b =
Leaf b
| Node a (f (Tree f a b))
type Tree' f a =
Tree f a a
type Tree0 a b =
Tree [] a b
type Tree0' a =
Tree0 a a
type Tree1 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
liftEq2 _ _ (Leaf _) (Node _ _) =
False
liftEq2 _ _ (Node _ _) (Leaf _) =
False
liftEq2 f g (Node a1 t1) (Node a2 t2) =
f a1 a2 && liftEq (liftEq2 f g) t1 t2
instance Ord1 f => Ord2 (Tree f) where
liftCompare2 _ g (Leaf b1) (Leaf b2) =
g b1 b2
liftCompare2 _ _ (Leaf _) (Node _ _) =
GT
liftCompare2 _ _ (Node _ _) (Leaf _) =
LT
liftCompare2 f g (Node a1 t1) (Node a2 t2) =
f a1 a2 <> liftCompare (liftCompare2 f g) t1 t2
instance Show1 f => Show2 (Tree f) where
liftShowsPrec2 _ _ spB _ d (Leaf b) =
showsUnaryWith spB "Leaf" d b
liftShowsPrec2 spA slA spB slB d (Node a ts) =
showsBinaryWith spA (liftShowsPrec (liftShowsPrec2 spA slA spB slB) (liftShowList2 spA slA spB slB)) "Node" d a ts
instance (Eq a, Eq1 f) => Eq1 (Tree f a) where
liftEq =
liftEq2 (==)
instance (Ord a, Ord1 f) => Ord1 (Tree f a) where
liftCompare =
liftCompare2 compare
instance (Show a, Show1 f) => Show1 (Tree f a) where
liftShowsPrec =
liftShowsPrec2 showsPrec showList
instance (Eq a, Eq1 f, Eq b) => Eq (Tree f a b) where
(==) =
liftEq (==)
instance (Ord a, Ord1 f, Ord b) => Ord (Tree f a b) where
compare =
liftCompare compare
instance (Show a, Show1 f, Show b) => Show (Tree f a b) where
showsPrec =
liftShowsPrec showsPrec shows
-- |
--
-- >>> Leaf "ABC" <> Leaf "DEF" :: Tree1' String
-- Leaf "ABCDEF"
--
-- >>> Leaf "ABC" <> Node "DEF" [] :: Tree0' String
-- Node "DEF" []
--
-- >>> Leaf "ABC" <> Node "DEF" [Leaf "GHI"] :: Tree0' String
-- Node "DEF" [Leaf "ABCGHI"]
--
-- >>> Node "ABC" [] <> Leaf "DEF" :: Tree0' String
-- Node "ABC" []
--
-- >>> Node "ABC" [] <> Node "DEF" [Leaf "GHI"] :: Tree0' String
-- Node "ABCDEF" []
--
-- >>> Node "ABC" [] <> Node "DEF" [Leaf "GHI", Node "JKL" []] :: Tree0' String
-- Node "ABCDEF" []
instance (Applicative f, Semigroup a, Semigroup b) => Semigroup (Tree f a b) where
Leaf a1 <> Leaf a2 =
Leaf (a1 <> a2)
Leaf a <> Node b t =
Node b (fmap (Leaf a <>) t)
Node b t <> Leaf a =
Node b (fmap (Leaf a <>) t)
Node b1 t1 <> Node b2 t2 =
Node (b1 <> b2) (liftA2 (<>) t1 t2)
instance (Applicative f, Monoid a, Monoid b) => Monoid (Tree f a b) where
mempty = Leaf mempty
-- |
--
-- >>> bimap (+1) (+2) (Leaf 10) :: Tree0' Int
-- Leaf 12
--
-- >>> bimap (+1) (+2) (Node 20 [Leaf 10]) :: Tree0' Int
-- Node 21 [Leaf 12]
--
-- >>> bimap (+1) (+2) (Node 20 [Node 30 [Leaf 10], Leaf 40]) :: Tree0' 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) :: Tree0' Int
-- Leaf 11
--
-- >>> fmap (+1) (Node 20 [Leaf 10]) :: Tree0' Int
-- Node 20 [Leaf 11]
--
-- >>> fmap (+1) (Node 20 [Node 30 [Leaf 10], Leaf 40]) :: Tree0' Int
-- Node 20 [Node 30 [Leaf 11],Leaf 41]
instance Functor f => Functor (Tree f a) where
fmap =
bimap id
-- >>> Leaf (+1) <.> Leaf 10 :: Tree0' Int
-- Leaf 11
--
-- >>> Leaf (+1) <.> Node 10 [] :: Tree0' Int
-- Node 10 []
--
-- >>> Node 20 [] <.> Node 10 [] :: Tree0' Int
-- Node 20 []
--
-- >>> Node 20 [] <.> Leaf 10 :: Tree0' Int
-- Node 20 []
--
-- >>> Leaf (+1) <.> Node 20 [Leaf 10] :: Tree0' Int
-- Node 20 [Leaf 11]
--
-- >>> Node 10 [] <.> Node 20 [Leaf 10] :: Tree0' 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 :: Tree0' Int
-- Leaf 10
instance Functor f => Applicative (Tree f a) where
pure =
Leaf
(<*>) =
(<.>)
-- |
--
-- >>> Leaf 10 >>- \n -> Leaf (n + 1) :: Tree0' Int
-- Leaf 11
--
-- >>> Leaf 10 >>- \n -> Node 20 [] :: Tree0' Int
-- Node 20 []
--
-- >>> Leaf 10 >>- \n -> Node 20 [Leaf 30] :: Tree0' Int
-- Node 20 [Leaf 30]
--
-- >>> Node 10 [] >>- Leaf
-- Node 10 []
--
-- >>> Node 10 [] >>- \n -> Node 20 [Leaf n] :: Tree0' 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 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 f (Leaf b) =
Leaf <$> f b
traverse f (Node a ts) =
Node a <$> traverse (traverse f) ts
-- |
--
-- >>> toListOf plate (Leaf 1 :: Tree0' Int)
-- [Leaf 1]
--
-- >>> 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 f (Leaf b) =
f (Leaf b)
plate f (Node a ts) =
Node a <$> traverse f ts
matchTree ::
(b -> x)
-> (a -> f (Tree f a b) -> x)
-> Tree f a b -> x
matchTree l _ (Leaf b) =
l b
matchTree _ n (Node a t) =
n a t
foldTree ::
Functor f =>
(b -> x)
-> (a -> f x -> x)
-> Tree f a b
-> x
foldTree l _ (Leaf b) =
l b
foldTree l n (Node a t) =
n a (fmap (foldTree l n) t)
-- |
--
-- >>> foldTreeM (\b -> [b, b]) (:) (Leaf 1)
-- [1,1]
--
-- >>> foldTreeM (\b -> [b, b]) (:) (Leaf 1)
-- [1,1]
--
-- >>> foldTreeM (\b -> [b, b]) (:) (Node 1 [Leaf 2])
-- [1,2,1,2]
--
-- >>> foldTreeM (\b -> [b, b]) (:) (Node 1 [Leaf 2, Leaf 3])
-- [1,2,3,1,2,3,1,2,3,1,2,3]
--
-- >>> foldTreeM (\b -> [b, b]) (:) (Node 1 [Leaf 2, Leaf 3, Node 4 []])
-- [1,2,3,4,1,2,3,4,1,2,3,4,1,2,3,4]
--
-- >>> foldTreeM (\b -> [b, b * 10]) (:) (Leaf 1)
-- [1,10]
--
-- >>> foldTreeM (\b -> [b, b * 10]) (:) (Leaf 1)
-- [1,10]
--
-- >>> foldTreeM (\b -> [b, b * 10]) (:) (Node 1 [Leaf 2])
-- [1,2,1,20]
--
-- >>> foldTreeM (\b -> [b, b * 10]) (:) (Node 1 [Leaf 2, Leaf 3])
-- [1,2,3,1,2,30,1,20,3,1,20,30]
--
-- >>> foldTreeM (\b -> [b, b * 10]) (:) (Node 1 [Leaf 2, Leaf 3, Node 4 []])
-- [1,2,3,4,1,2,30,4,1,20,3,4,1,20,30,4]
foldTreeM ::
(Monad m, Traversable f) =>
(b -> m x)
-> (a -> f x -> m x)
-> Tree f a b
-> m x
foldTreeM l _ (Leaf b) =
l b
foldTreeM l n (Node a t) =
traverse (foldTreeM l n) t >>= n a
foldTreeM_ ::
(Monad m, Traversable f) =>
(b -> m x) ->
(a -> f x -> m x)
-> Tree f a b
-> m ()
foldTreeM_ l n t =
void (foldTreeM l n t)
-- |
--
-- >>> treeValue (Leaf 1 :: Tree0' Int)
-- Right 1
--
-- >>> treeValue (Node 1 [] :: Tree0' Int)
-- Left 1
--
-- >>> treeValue (Node 1 [Leaf 2] :: Tree0' Int)
-- Left 1
--
-- >>> treeValue (Node 1 [Node 2 []] :: Tree0' Int)
-- Left 1
treeValue ::
Tree f a b
-> Either a b
treeValue =
matchTree Right (pure . Left)
-- |
--
-- >>> treeChildren (Leaf 1 :: Tree0' Int)
-- Left 1
--
-- >>> treeChildren (Node 1 [] :: Tree0' Int)
-- Right []
--
-- >>> treeChildren (Node 1 [Leaf 2] :: Tree0' Int)
-- Right [Leaf 2]
--
-- >>> treeChildren (Node 1 [Leaf 2, Node 3 []] :: Tree0' Int)
-- Right [Leaf 2,Node 3 []]
treeChildren ::
Tree f a b
-> Either b (f (Tree f a b))
treeChildren =
matchTree Left (pure Right)
-- |
--
-- >>> toListOf nodeValue (Leaf 1)
-- []
--
-- >>> toListOf nodeValue (Node 1 [] :: Tree0' Int)
-- [1]
--
-- >>> toListOf nodeValue (Node 1 [Leaf 2] :: Tree0' Int)
-- [1]
--
-- >>> toListOf nodeValue (Node 1 [Leaf 2, Node 3 []] :: Tree0' Int)
-- [1]
nodeValue ::
Traversal'
(Tree f a b)
a
nodeValue =
_Node . _1
-- |
--
-- >>> toListOf nodeChildren (Leaf 1 :: Tree0' Int)
-- []
--
-- >>> toListOf nodeChildren (Node 1 [] :: Tree0' Int)
-- [[]]
--
-- >>> toListOf nodeChildren (Node 1 [Leaf 2] :: Tree0' Int)
-- [[Leaf 2]]
--
-- >>> toListOf nodeChildren (Node 1 [Leaf 2, Node 3 []] :: Tree0' Int)
-- [[Leaf 2,Node 3 []]]
nodeChildren ::
Traversal
(Tree f a b)
(Tree f' a b)
(f (Tree f a b))
(f' (Tree f' a b))
nodeChildren =
_Node . _2
-- | Depth-first search
--
-- >>> dfs (Leaf 1) :: [Either String Int]
-- [Right 1]
--
-- >>> dfs (Node "A" []) :: [Either String Int]
-- [Left "A"]
--
-- >>> dfs (Node "A" [Leaf 1]) :: [Either String Int]
-- [Left "A",Right 1]
--
-- >>> dfs (Node "a" [Node "b" [Leaf 1], Leaf 88, Node "c" [Leaf 2], Leaf 99]) :: [Either String Int]
-- [Left "a",Left "b",Right 1,Right 88,Left "c",Right 2,Right 99]
dfs ::
(Semigroup (f (Either a b)), Monad f) =>
Tree f a b
-> f (Either a b)
dfs (Leaf b) =
pure (Right b)
dfs (Node a ts) =
pure (Left a) <> (ts >>= dfs)
-- | Breadth-first search
--
-- >>> bfs (Leaf 1) :: [Either String Int]
-- [Right 1]
--
-- >>> bfs (Node "A" []) :: [Either String Int]
-- [Left "A"]
--
-- >>> bfs (Node "A" [Leaf 1]) :: [Either String Int]
-- [Left "A",Right 1]
--
-- >>> bfs (Node "a" [Node "b" [Leaf 1], Leaf 88, Node "c" [Leaf 2], Leaf 99]) :: [Either String Int]
-- [Left "a",Left "b",Right 88,Left "c",Right 99,Right 1,Right 2]
bfs ::
(Monoid (f (Either a b)), Monad f, Foldable f) =>
Tree f a b
-> f (Either a b)
bfs (Leaf b) =
pure (Right b)
bfs (Node a ts) =
let go xs =
foldMap
(`foldMap` xs)
[pure . treeValue, maybe mempty go . preview _Right . treeChildren]
in pure (Left a) <> go ts
_Leaf ::
Prism'
(Tree f a b)
b
_Leaf =
prism'
Leaf
(\case
Leaf b ->
Just b
_ ->
Nothing)
_Node ::
Prism
(Tree f a b)
(Tree f' a' b)
(a, f (Tree f a b))
(a', f' (Tree f' a' b))
_Node =
prism
(uncurry Node)
(\case
Node a t ->
Right (a, t)
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) =
liftA2 Node (foldMap 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)
)
nodeA ::
Alternative f =>
a
-> Tree f a b
nodeA a =
Node a empty
node ::
a
-> f (Tree f a b)
-> Tree f a b
node =
Node
node0 ::
a
-> [Tree0 a b]
-> Tree0 a b
node0 =
Node
node1 ::
a
-> Tree1 a b
-> Tree1 a b
node1 a t =
review _Node1 (a, t)
-- |
--
-- >>> traverseNode (\(a, t) -> [(a, t)]) (Leaf 1 :: Tree0' Int)
-- [Leaf 1]
--
-- >>> traverseNode (\(a, t) -> [(a, t)]) (Node 1 [] :: Tree0' Int)
-- [Node (1,[]) []]
--
-- >>> traverseNode (\(a, t) -> [(a, t)]) (Node 1 [Leaf 2] :: Tree0' Int)
-- [Node (1,[Leaf 2]) [Leaf 2]]
--
-- >>> traverseNode (\(a, t) -> [(a, t)]) (Node 1 [Leaf 2, Node 3 []] :: Tree0' Int)
-- [Node (1,[Leaf 2,Node 3 []]) [Leaf 2,Node (3,[]) []]]
traverseNode ::
Traversable f =>
Traversal (Tree f a b) (Tree f a' b) (a, f (Tree f a b)) a'
traverseNode _ (Leaf b) =
pure (Leaf b)
traverseNode f (Node a t) =
Node <$> f (a, t) <*> traverse (traverseNode f) t
traverseNode_ ::
Foldable f =>
Traversal (Tree f a b) () (a, f (Tree f a b)) a'
traverseNode_ _ (Leaf b) =
void (pure (Leaf b))
traverseNode_ f (Node a t) =
f (a, t) *> traverse_ (traverseNode_ f) t
-- |
--
-- >>> view treeIso (Leaf 1 :: Tree0' Int)
-- (1,Nothing)
--
-- >>> view treeIso (Node 1 [] :: Tree0' Int)
-- (1,Just [])
--
-- >>> view treeIso (Node 1 [Leaf 2] :: Tree0' Int)
-- (1,Just [Leaf 2])
--
-- >>> view treeIso (Node 1 [Leaf 2, Node 3 []] :: Tree0' Int)
-- (1,Just [Leaf 2,Node 3 []])
treeIso ::
Iso
(Tree' f a)
(Tree' f' a')
(a, Maybe (f (Tree' f a)))
(a', Maybe (f' (Tree' f' a')))
treeIso =
iso
(matchTree (, Nothing) (\a t -> (a, Just t)))
(\(a, t) -> maybe (Leaf a) (Node a) t)
-- |
--
-- >>> leaves (Leaf 1 :: Tree0' Int)
-- [1]
--
-- >>> leaves (Node 1 [] :: Tree0' Int)
-- []
--
-- >>> leaves (Node 1 [Leaf 2] :: Tree0' Int)
-- [2]
--
-- >>> leaves (Node 1 [Leaf 2, Node 3 []] :: Tree0' Int)
-- [2]
--
-- >>> leaves (Node 1 [Leaf 2, Node 3 [Leaf 4]] :: Tree0' Int)
-- [2,4]
leaves ::
(Traversable f, Alternative f) =>
Tree f a b
-> f b
leaves (Leaf b) =
pure b
leaves (Node _ t) =
asum (fmap leaves t)
-- |
--
-- >>> view treeValue' (Leaf 1 :: Tree0' Int)
-- 1
--
-- >>> view treeValue' (Node 1 [] :: Tree0' Int)
-- 1
--
-- >>> view treeValue' (Node 1 [Leaf 2] :: Tree0' Int)
-- 1
--
-- >>> view treeValue' (Node 1 [Leaf 2, Node 3 []] :: Tree0' Int)
-- 1
treeValue' ::
Lens'
(Tree' f a)
a
treeValue' =
treeIso . _1
-- |
--
-- >>> view treeChildren' (Leaf 1 :: Tree0' Int)
-- Nothing
--
-- >>> view treeChildren' (Node 1 [] :: Tree0' Int)
-- Just []
--
-- >>> view treeChildren' (Node 1 [Leaf 2, Leaf 3] :: Tree0' Int)
-- Just [Leaf 2,Leaf 3]
--
-- >>> view treeChildren' (Node 1 [Leaf 2, Leaf 3, Node 4 []] :: Tree0' Int)
-- Just [Leaf 2,Leaf 3,Node 4 []]
--
-- >>> view treeChildren' (Node 1 [Leaf 2, Leaf 3, Node 4 [Node 5 []]] :: Tree0' Int)
-- Just [Leaf 2,Leaf 3,Node 4 [Node 5 []]]
treeChildren' ::
Lens
(Tree' f a)
(Tree' f' a)
(Maybe (f (Tree' f a)))
(Maybe (f' (Tree' f' a)))
treeChildren' =
treeIso . _2
treeFree ::
(Functor f, Functor f') =>
Iso
(Tree f a b)
(Tree f' a' b')
(Free (Compose ((,) a) f) b)
(Free (Compose ((,) a') f') b')
treeFree =
iso
(foldTree Pure (\a t -> Free (Compose (a, t))))
(
let go (Pure b) =
Leaf b
go (Free x) =
let (a, t) = getCompose x
in Node a (fmap go t)
in go
)
treeFreeT ::
(Functor f, Functor f') =>
Iso
(Tree f a b)
(Tree f' a' b')
(FreeT.Free (Compose ((,) a) f) b)
(FreeT.Free (Compose ((,) a') f') b')
treeFreeT =
iso
(foldTree (FreeT.free . FreeT.Pure) (\a t -> FreeT.free (FreeT.Free (Compose (a, t)))))
(
let go (FreeT.Pure b) =
Leaf b
go (FreeT.Free x) =
let (a, t) = getCompose x
in Node a (fmap (go . FreeT.runFree) t)
in go . FreeT.runFree
)
-- |
--
-- >>> 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)
(Tree0 a' Void)
(Tree.Tree a)
(Tree.Tree a')
baseTree =
let mkTree h c =
let go (Node a t) =
Tree.Node a (fmap go t)
go (Leaf b) =
absurd b
in Tree.Node h (fmap go c)
mkTree0 (Tree.Node h t) = Node h (fmap mkTree0 t)
in iso
(matchTree absurd mkTree)
(\(Tree.Node h t) -> Node h (fmap mkTree0 t))