https://www.reddit.com/r/haskell/comments/fcd8s3/how_to_pretty_print_an_adt_using_recursion_schemes/

ShowTree.hs

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, TypeFamilies, TemplateHaskell #-}

import Data.Functor.Foldable
import Data.Functor.Foldable.TH
import Data.Functor.Compose

-- Example type
data Exp
  = IntValue Int
  | Sum Exp Exp
  | Square Exp

$(makeBaseFunctor ''Exp)

{-
  Objective: display an Exp as a tree.

  Example output:

  Sum
   Sum
    IntValue 1
    IntValue 2
   Square
    IntValue 3
-}

{-
  Plan:
  1. Annotate each Exp node with its depth
  2. Fold the annotated tree to collect all pairs (Depth, NodeName) corresponding to each line
  3. Render the result, using the depth to indent each name
-}

-- * Part 1: Annotate each Exp node with its depth.

-- ** 1.1: Define the type of expressions annotated with depth

{-
  From the definition of Exp, and more specifically its base functor ExpF,
  we can derive the following type AnnExp, equivalent to:

  data AnnExp
    = IntValue Depth Int
    | Sum      Depth AnnExp AnnExp
    | Square   Depth AnnExp
-}

type AnnExp = Fix (Compose ((,) Depth) ExpF)
-- Alternatively,
--   Cofree ExpF Depth
-- or
--   Fix (Product (Const Depth) ExpF)     (using Data.Functor.Product)
-- would also work

type Depth = Int

-- ** 1.2: Fold expressions to annotate them

{-
  Let us explain in detail how to implement this function:
-}

annDepth :: Exp -> AnnExp

{-
  What result type "a" to use with cata?

    cata :: (ExpF a -> a) -> Exp -> a

  1. We want to produce an AnnExp as an output.
  2. While folding the Exp, we need to know the current depth.

  So,

    a = Depth -> AnnExp

  At the top level, we start from depth 0.

    annDepth :: Exp -> AnnExp
    annDepth e = cata _ e 0

  We now need the first argument of cata, an algebra, of the following type:

    depthF :: ExpF (Depth -> AnnExp) -> Depth -> AnnExp

  "Use the types, Luke."

  The types guide the implementation.

  Take two arguments (y :: ExpF (Depth -> AnnExp)) and (n :: Depth);

    depthF y n = (_ :: AnnExp)

  Unfold the definition of AnnExp; it starts with Fix, Compose,
  only one possible constructor at every step:

    depthF y n = Fix (Compose (_ :: (Depth, ExpF AnnExp)))

  So we have to construct a pair (Depth, ExpF AnnExp).
  Stick the current depth n in the first component;

    depthF y n = Fix (Compose (n, _ :: ExpF AnnExp))

  For the second component, we need to transform

    y :: ExpF (Depth -> AnnExp)

  into some (_ :: ExpF AnnExp). Intuitively, after adding the depth (which we
  already did), the rest of the current node stays untouched. We only need
  to modify the children. That's exactly what fmap does with ExpF:

    depthF y n = Fix (Compose (n, fmap (_ :: (Depth -> AnnExp) -> AnnExp) y))

  Now we have to apply the children, which are functions of their current Depth.
  The depth of a children is the current depth n plus one.

    depthF y n = Fix (Compose (n, fmap (\z -> z (n + 1)) y))

  QED.

  All of that fits in three lines of code.
-}
annDepth e = cata depthF e 0 where
  depthF :: ExpF (Depth -> AnnExp) -> Depth -> AnnExp
  depthF y n = Fix (Compose (n, fmap (\z -> z (n + 1)) y))

-- * Part 2: fold the annotated tree to collect all pairs (Depth, NodeName)

type NodeName = String

{-
  As usual, types come first.
-}

collect :: AnnExp -> [(Depth, NodeName)]

{-
  Once we have the depth, there is no more context needed.
  So the result type for cata is directly going to be [(Depth, NodeName)].

    cata (_ :: f a -> a) :: Fix f  -> a
    --                   :: AnnExp -> a

  Here, a = [(Depth, NodeName)]
        f = Compose ((,) Depth) ExpF

  So we need an algebra with this type:

    collectF :: Compose ((,) Depth) ExpF [(Depth, NodeName)] -> [(Depth, NodeName)]

  Again, follow the types.

  We can destructure Compose and (,) canonically:

    collectF (Compose (n, e)) = _ :: [(Depth, NodeName)]

  The result is going to contain the current node, followed by its children:

    collectF (Compose (n, e)) =
      (_ :: (Depth, NodeName)) : (_ :: [(Depth, NodeName)])

  The current depth is n. The name of the node needs to be read from the node.

    collectF (Compose (n, e)) =
      (n, nameOf e) : (_ :: [(Depth, NodeName)])

    -- For some definition of nameOf (see full code below).

  Then we need to collect the children of (e :: ExpF [(Depth, NodeName)]).
  ExpF is Foldable, so we can use concat :: ExpF [a] -> [a].

    collectF (Compose (n, e)) =
      (n, nameOf e) : concat e

  QED.
-}
collect = cata collectF where
  collectF :: Compose ((,) Depth) ExpF [(Depth, NodeName)] -> [(Depth, NodeName)]
  collectF (Compose (n, e)) =
    (n, nameOf e) : concat e

  nameOf :: ExpF a -> NodeName
  nameOf (IntValueF n) = "IntValue " ++ show n
  nameOf (SumF _ _) = "Sum"
  nameOf (SquareF _) = "Square"

-- * Part 3: Render the result, using the depth to indent each name

{-
  This is straightforward, and doesn't involve recursion schemes,
  so I'm not going to explain.

  Just note this function has been code-golfed a little. Your first attempt may
  be longer, and that would be okay too.
-}
indent :: [(Depth, NodeName)] -> String
indent = unlines . fmap indentLine where
  indentLine (n, s) = replicate n ' ' ++ s

{-
  Put all the pieces together...
-}
showTree :: Exp -> String
showTree = indent . collect . annDepth

main :: IO ()
main = do
  putStr $ showTree $
    Sum (Sum (IntValue 1) (IntValue 2)) (Square (IntValue 3))

-- Exercises for the reader:
-- 1. Refactor to fuse all three steps in a single fold.
-- 2. Use difference lists instead of plain lists for linear time complexity.
-- 3. Generalize from Exp to any instance of Recursive (with whatever
--    additional constraints turn out to be necessary).
--
--    The part most specific to Exp is the nameOf auxiliary function,
--    which you can take as a parameter first, and later figure out
--    how to automate as an orthogonal problem.
--
--    showTree :: forall expF exp. (_) => (forall a. expF a -> NodeName) -> exp -> String
--    --                           ^^^ TODO