How can I walk this type with a recursion scheme instead of explicit recursion?

Question

Consider this code:

import Data.Maybe (fromMaybe)

data MyStructure = Foo Int | Bar String MyStructure | Baz MyStructure MyStructure | Qux Bool Bool MyStructure MyStructure deriving(Eq,Show)

makeReplacements :: [(MyStructure, MyStructure)] -> MyStructure -> MyStructure
makeReplacements replacements structure = fromMaybe (descend structure) (lookup structure replacements)
  where
    descend :: MyStructure -> MyStructure
    descend (Foo x) = Foo x
    descend (Bar x y) = Bar x (makeReplacements replacements y)
    descend (Baz x y) = Baz (makeReplacements replacements x) (makeReplacements replacements y)
    descend (Qux x y z w) = Qux x y (makeReplacements replacements z) (makeReplacements replacements w)

It defines a recursive data type, and a function that performs a search-and-replace by walking it. However, I'm using explicit recursion and would like to use a recursion scheme instead.

First, I threw in makeBaseFunctor ''MyStructure. For clarity, I expanded the resulting Template Haskell and the derived Functor instance below. I was then able to rewrite descend:

{-# LANGUAGE DeriveTraversable, TypeFamilies #-}

import Data.Maybe (fromMaybe)
import Data.Functor.Foldable (Base, Recursive(..), Corecursive(..))

data MyStructure = Foo Int | Bar String MyStructure | Baz MyStructure MyStructure | Qux Bool Bool MyStructure MyStructure deriving(Eq,Show)

makeReplacements :: [(MyStructure, MyStructure)] -> MyStructure -> MyStructure
makeReplacements replacements structure = fromMaybe (descend structure) (lookup structure replacements)
  where
    descend :: MyStructure -> MyStructure
    descend = embed . fmap (makeReplacements replacements) . project

-- begin code that would normally be auto-generated
data MyStructureF r = FooF Int | BarF String r | BazF r r | QuxF Bool Bool r r deriving(Foldable,Traversable)

instance Functor MyStructureF where
  fmap _ (FooF x) = FooF x
  fmap f (BarF x y) = BarF x (f y)
  fmap f (BazF x y) = BazF (f x) (f y)
  fmap f (QuxF x y z w) = QuxF x y (f z) (f w)

type instance Base MyStructure = MyStructureF

instance Recursive MyStructure where
  project (Foo x) = FooF x
  project (Bar x y) = BarF x y
  project (Baz x y) = BazF x y
  project (Qux x y z w) = QuxF x y z w

instance Corecursive MyStructure where
  embed (FooF x) = Foo x
  embed (BarF x y) = Bar x y
  embed (BazF x y) = Baz x y
  embed (QuxF x y z w) = Qux x y z w
-- end code that would normally be auto-generated

If I were to stop here, I'd already have a win: I no longer have to write out all of the cases in descend, and I can't accidentally make a mistake like descend (Baz x y) = Baz x (makeReplacements replacements y) (forgetting to replace inside x). However, there's still explicit recursion here, since I'm still using makeReplacements from inside its own definition. How can I rewrite this to remove that, so that I'm doing all of my recursion inside of the recursion schemes?

Answer 1

I found a solution that I'm reasonably happy with: an apomorphism.

makeReplacements replacements = apo coalg
  where
    coalg :: MyStructure -> MyStructureF (Either MyStructure MyStructure)
    coalg structure = case lookup structure replacements of
      Just replacement -> Left <$> project replacement
      Nothing -> Right <$> project structure

Having thought about this a little more, I also saw a symmetry in this that leads to an equivalent paramorphism:

makeReplacements replacements = para alg
  where
    alg :: MyStructureF (MyStructure, MyStructure) -> MyStructure
    alg structure = case lookup (embed $ fst <$> structure) replacements of
      Just replacement -> replacement
      Nothing -> embed $ snd <$> structure