6

考虑这段代码：

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它自己的定义。我如何重写它以删除它，以便我在递归方案中进行所有递归？

4

2 回答 2

6

我找到了一个我相当满意的解决方案：同形异形。

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
于 2019-10-01T01:28:25.713 回答
3

跟进您的问题下的讨论

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))
于 2019-10-01T00:02:57.860 回答