如何实现可基于返回类型任意值构造的Anamorphism？

背景定义 #

首先是固定点函子和标准Anamorphism的定义：

-- Fixed point of a Functor 
newtype Fix f = In (f (Fix f))

deriving instance (Eq (f (Fix f))) => Eq (Fix f)
deriving instance (Ord (f (Fix f))) => Ord (Fix f)
deriving instance (Show (f (Fix f))) => Show (Fix f)

out :: Fix f -> f (Fix f)
out (In f) = f

-- 标准Anamorphism的余代数类型
type Coalgebra f a = a -> f a

ana :: (Functor f) => Coalgebra f a -> a -> Fix f
ana f = In . fmap (ana f) . f

列表函子及其固定点类型：

data ListF a r = NilF | ConsF a r deriving (Eq, Ord, Show)
instance Functor (ListF a) where
  fmap _ NilF = NilF
  fmap f (ConsF a r) = ConsF a (f r)

type ListF' a = Fix (ListF a)

当前的append余代数需要逐个构造第二个列表的元素，无法直接复用已有的列表结构：

appendListCoAlg :: (ListF' a, ListF' a) -> ListF a (ListF' a, ListF' a)
appendListCoAlg (In (ConsF a as), listb) = ConsF a (as, listb)
appendListCoAlg (In NilF, In (ConsF b bs)) = ConsF b (In NilF, bs)
appendListCoAlg (In NilF, In NilF) = NilF

解决方案：使用Apomorphism #

你需要的是Apomorphism（余同态的扩展），它允许余代数直接返回已经构造好的固定点值（Fix f），从而提前终止递归，复用已有结构。

1. 定义Apomorphism的余代数类型 #

-- Apomorphism的余代数：返回的函子值中，递归位置可以是Either (Fix f) a
-- Left fx表示直接使用已有的fx，Right seed表示继续递归
type APCoalgebra f a = a -> f (Either (Fix f) a)

2. 实现Apomorphism函数apo #

apo :: Functor f => APCoalgebra f a -> a -> Fix f
apo coalg = In . fmap step . coalg
  where
    step (Left fx) = fx          -- 直接复用已有的固定点值
    step (Right seed) = apo coalg seed  -- 继续递归生成

3. 改写append余代数 #

现在可以写出符合需求的余代数，直接复用第二个列表的结构：

appendListCoAlg :: (ListF' a, ListF' a) -> ListF a (Either (ListF' a) (ListF' a, ListF' a))
-- 第一个列表非空：继续递归处理剩余部分
appendListCoAlg (In (ConsF a as), listb) = ConsF a (Right (as, listb))
-- 第一个列表为空：直接复用第二个列表的所有结构
appendListCoAlg (In NilF, bs) = fmap Left (out bs)

效果验证 #

当调用apo appendListCoAlg (listA, listB)时：

• 如果listA非空，会逐个展开listA的元素，递归处理剩余部分；
• 如果listA为空，会直接将listB的结构作为结果返回，无需逐个构造元素，完全符合你想要的"提前返回"需求。

内容的提问来源于stack exchange，提问作者cocorudeboy