Recursion schemes (derive Functor/Traversable/Foldable via catamorphism and Bifunctor/Bitraversable/Bifoldable)

tree.purs

module Tree where

import Control.Monad.Writer
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Foldable
import Data.Generic
import Data.Monoid
import Data.Monoid.Additive
import Data.String
import Data.Traversable
import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, logShow)
import Data.List as L
import Data.List.Lazy.NonEmpty (fromFoldable)
import Data.NonEmpty (NonEmpty(..))
import Matryoshka (class Corecursive, class Recursive, Algebra, AlgebraM, cata, cataM, embed, project)

data Tree e = Branch (L.List (Tree e)) | Leaf e
data TreeF e r = BranchF (L.List r) | LeafF e

-- derive instance treeFFunctor :: Functor (TreeF a)
derive instance treeGeneric :: Generic a => Generic (Tree a)

instance treeFFunctor :: Functor (TreeF a) where
  map f (LeafF a) = LeafF a
  map f (BranchF as) = BranchF (map f as)

instance treeFFoldable :: Foldable (TreeF a) where
  foldr f = foldrDefault f
  foldl f = foldlDefault f
  foldMap f (LeafF a) = mempty
  foldMap f (BranchF as) = foldMap f as

instance treeFTraversable :: Traversable (TreeF a) where
  traverse f (LeafF a) = pure (LeafF a)
  traverse f (BranchF as) = map BranchF (traverse f as)
  sequence f = sequenceDefault f

instance treeFBifoldable :: Bifoldable TreeF where
  bifoldr f g = bifoldrDefault f g
  bifoldl f g = bifoldlDefault f g
  bifoldMap f _ (LeafF e)    = f e
  bifoldMap _ g (BranchF xs) = foldMap g xs

instance treeFoldable :: Foldable Tree where
  foldr f = foldrDefault f
  foldl f = foldlDefault f
  foldMap f = cata (bifoldMap f id)

instance treeFBitraversable :: Bitraversable TreeF where
  bitraverse f _ (LeafF e)    = LeafF <$> f e
  bitraverse _ g (BranchF xs) = BranchF <$> traverse g xs
  bisequence = bisequenceDefault

instance treeTraversable :: Traversable Tree where
  traverse f = cata (map embed <<< bitraverse f id)
  sequence = sequenceDefault

instance recursiveTree ∷ Recursive (Tree a) (TreeF a) where
  project x = case x of
    Leaf a -> LeafF a
    Branch as -> BranchF as

instance corecursiveTree ∷ Corecursive (Tree a) (TreeF a) where
  embed x = case x of
    LeafF a -> Leaf a
    BranchF as -> Branch as

instance bifuctorTree :: Bifunctor TreeF where
    bimap f _ (LeafF e)    = LeafF (f e)
    bimap _ g (BranchF xs) = BranchF (map g xs)

instance treeFunctor :: Functor Tree where
    map f = cata (embed <<< lmap f)

-- instance showTree :: Generic a => Show (Tree a) where
--   show = gShow

instance showTree :: Show a => Show(Tree a) where
    show = cata alg where
        alg = case _ of
            LeafF a -> "Leaf " <> show a
            BranchF as -> "Branch " <> "[" <> joinWith ", " (L.toUnfoldable as) <> "]"

alg :: TreeF Int Int -> Int
alg = case _ of
    LeafF a -> a
    BranchF as -> foldr(+) 0 as

alg2 :: forall a. Semiring a => Algebra (TreeF a) (Additive a)
alg2 = case _ of
    LeafF a -> Additive a
    BranchF as -> fold as  

tree :: Tree Int
tree = Branch (L.fromFoldable [Leaf 10, Leaf 20, Branch (L.fromFoldable [Leaf 30, Leaf 40])])

evalM :: AlgebraM (Writer (Array String)) (TreeF Int) Unit
evalM (LeafF a) = do
  tell $ [ "visiting leaf " <> show a]
  pure unit
evalM (BranchF as) = pure unit

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
    logShow $ runWriter $ cataM evalM tree