https://www.reddit.com/r/haskell/comments/aj2xwn/is_there_something_deeper_in_this_stateful_tree/

cotransverse.hs

{-# LANGUAGE
    DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell,
    RankNTypes, LambdaCase #-}

import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)

data Tree a = Leaf a | Branch a (Tree a) (Tree a)

makeBaseFunctor ''Tree

thing :: Tree a -> s -> (s -> a -> b) -> (s -> a -> (s, s, b)) -> Tree b
thing (Leaf x) s f _ = Leaf (f s x)
thing (Branch x l r) s f g = Branch y l' r'
    where (sl, sr, y) = g s x
          l' = thing l sl f g
          r' = thing r sr f g

cothing :: Tree a -> s -> (s -> a -> (b, s)) -> (a -> s -> s -> (b, s)) -> (Tree b, s)
cothing (Leaf x) s f _ = (Leaf y, s) where (y, s) = f s x
cothing (Branch x l r) s f g = (Branch y l' r', s_out)
    where (l', sl) = cothing l s f g
          (r', sr) = cothing r s f g
          (y, s_out) = g x sl sr

cothing' :: Tree a -> s -> (s -> a -> (b, s)) -> (a -> s -> s -> (b, s)) -> (Tree b, s)
cothing' t0 s0 f g =
  (\(x, y) -> (y, x)) $ transverse (\case
    LeafF a -> let (b, s') = f s0 a in (s', LeafF b)
    BranchF a (s1, t1) (s2, t2) ->
      let (b, s') = g a s1 s2 in
      (s', BranchF b t1 t2)) t0

thing' :: Tree a -> s -> (s -> a -> b) -> (s -> a -> (s, s, b)) -> Tree b
thing' t0 s0 f g =
  cotransverse (\case
    (s, LeafF a) -> LeafF (f s a)
    (s, BranchF a t1 t2) ->
      let (s1, s2, b) = g s a in
      BranchF b (s1, t1) (s2, t2)) (s0, t0)

transverse ::
  (Recursive s, Corecursive t, Functor f) =>
  (forall a. Base s (f a) -> f (Base t a)) ->
  s -> f t
transverse n = cata (fmap embed . n)

cotransverse ::
  (Recursive t, Corecursive s, Functor f) =>
  (forall a. f (Base t a) -> Base s (f a)) ->
  f t -> s
cotransverse n = ana (n . fmap project)