Some funny problem from a blog post (https://blog.ploeh.dk/2021/04/12/threading-context-through-a-catamorphism/). Excuse for recursion schemes

Main.hs

{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wall #-}

-- nix-shell -I nixpkgs=https://github.com/NixOS/nixpkgs/archive/bed08131cd29a85f19716d9351940bdc34834492.tar.gz -p 'haskellPackages.ghcWithPackages (p: [p.recursion-schemes])'

module Main where

import Control.Monad.Reader (Reader, asks, local, runReader)
import Data.Foldable (traverse_)
import Data.Functor.Base (TreeF (NodeF))
import Data.Functor.Foldable (cata, para)
import Data.Tree (Tree (Node))
import qualified Data.Tree as Tree
import System.FilePath ((</>))

type Directory = Tree FilePath

testTree :: Directory
testTree =
  Node
    "foo"
    [ Node
        "bar"
        [ Node
            "baz.txt"
            []
        ],
      Node
        "qux.txt"
        [],
      Node
        "qui"
        [ Node
            "wat.txt"
            []
        ]
    ]

flattenDir :: Directory -> [FilePath]
flattenDir dir = runReader (cata alg dir) ""
  where
    alg :: TreeF FilePath (Reader FilePath [FilePath]) -> Reader FilePath [FilePath]
    alg (NodeF path children) =
      (:)
        <$> asks (</> path)
        <*> local (</> path) (mconcat <$> sequenceA children)

flattenDir' :: Directory -> [FilePath]
flattenDir' = flip runReader "" . foldr alg (pure [])
  where
    alg :: FilePath -> Reader FilePath [FilePath] -> Reader FilePath [FilePath]
    alg path acc =
      (:)
        <$> asks (</> path)
        <*> local (</> path) acc

-- This is kind of fun
levelOrder :: Tree a -> [a]
levelOrder =
  (:)
    <$> Tree.rootLabel
    <*> para
      ( \(NodeF _ children) ->
          map (Tree.rootLabel . fst) children ++ foldMap snd children
      )

main :: IO ()
main = do
  putStrLn (Tree.drawTree testTree)
  traverse_ putStrLn (levelOrder testTree)
  putStrLn ""
  traverse_ putStrLn (flattenDir testTree)
  putStrLn ""
  traverse_ putStrLn (flattenDir' testTree)

-- >>> :main
-- foo
-- |
-- +- bar
-- |  |
-- |  `- baz.txt
-- |
-- +- qux.txt
-- |
-- `- qui
--    |
--    `- wat.txt
--
-- foo
-- bar
-- qux.txt
-- qui
-- baz.txt
-- wat.txt
--
-- foo
-- foo/bar
-- foo/bar/baz.txt
-- foo/qux.txt
-- foo/qui
-- foo/qui/wat.txt
--
-- foo
-- foo/bar
-- foo/bar/baz.txt
-- foo/bar/baz.txt/qux.txt
-- foo/bar/baz.txt/qux.txt/qui
-- foo/bar/baz.txt/qux.txt/qui/wat.txt