如何使用递归方案而不是显式递归来遍历这种类型？

Question

考虑这段代码：

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)

它定义了一个递归数据类型，以及一个通过遍历它来执行搜索和替换的函数。但是，我正在使用显式递归，并希望使用递归方案。

首先，我输入了makeBaseFunctor ''MyStructure。为了清楚起见，我在下面扩展了生成的 Template Haskell 和派生的 Functor 实例。然后我就可以重写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

如果我在这里停下来，我已经赢了：我不再需要在descend 中写出所有案例，而且我不会不小心犯像descend (Baz x y) = Baz x (makeReplacements replacements y) 这样的错误（忘记替换内部x)。但是，这里仍然存在显式递归，因为我仍在使用 makeReplacements 在其自己的定义中。我怎样才能重写它以删除它，以便我在递归方案中进行所有递归？

Answer 1

我找到了一个我相当满意的解决方案：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

稍微考虑了一下，我还看到了其中的对称性，导致了等效的同构：

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

Answer 2

跟进您的问题下的讨论

para 是 (Base t (t, a) -> a) -> t -> a。对我来说，这看起来很接近，但并不完美。我真的不想要((t, Base t a) -> a) -> t -> a 或((t, Base t (t, a)) -> a) -> t -> a 以便我可以查看我所在的元素吗？

这仍然是一个变形。 para 的类型看起来很奇怪，但它是更精确的类型。一对(t, Base t a) 不编码两个组件总是具有“相同”构造函数的不变量。

您的建议似乎仍然是定义makeReplacements 的最自然方式，只是没有在递归方案库中定义。

para' :: Recursive t => (t -> Base t a -> a) -> t -> a
para' alg = go where
  go x = alg x (fmap go (project x))