TreeのForestを降りて行くサンプル

forest.hs

{-# LANGUAGE Rank2Types #-}

import Control.Applicative
import Control.Lens
import Control.Lens.Zipper
import Data.List
import Data.Tree
import Data.Tree.Lens

mkTree :: Int -> Tree Int
mkTree n = unfoldTree (\x -> (x, [1 .. (x - 1)]) ) n

printTree :: (Show a) => Tree a -> IO ()
printTree = putStr . drawTree . fmap show

forestAt :: (Eq a) => a -> Lens' (Tree a) (Tree a)
forestAt x f (Node y ts) = (\t -> Node y (replace index ts t)) <$> f (ts !! index)
  where
    index   = maybe (-1) id (elemIndex x (map (view root) ts))
    replace i as a = [if i == j then a else as !! j | j <- [0.. length as]]

forestPath :: (Eq a) => [a] -> Lens' (Tree a) (Tree a)
forestPath (x:[]) = forestAt x
forestPath (x:xs) = (forestAt x) . (forestPath xs)