是否存在可修改层级结构形状的Haskell类型类？

针对你遇到的递归数据结构中重复编写遍历逻辑的问题，有两种主要方案可以减少代码重复，提升扩展性：

方案一：自定义默认遍历函数/类型类 #

你可以先编写一个处理所有默认递归逻辑的辅助函数，只在需要特殊处理的构造器分支中自定义逻辑，其余情况复用默认逻辑：

1. 定义默认遍历函数 #

defaultWalk :: (Item a -> Item a) -> Item a -> Item a
defaultWalk f x@(Leaf _) = x
defaultWalk f (ListItems xs) = ListItems $ f <$> xs
defaultWalk f (DoubleItem x y) = DoubleItem (f x) (f y)
defaultWalk f (TripleItem x y z) = TripleItem (f x) (f y) (f z)

这个函数会递归处理所有子节点，并保持原构造器的结构，只有你在业务函数中覆盖的分支会被修改。

2. 简化业务函数 #

现在你的removeDoubles和removeTriples只需要编写特殊分支，其余情况直接调用defaultWalk：

removeDoubles :: Item a -> Item a
removeDoubles (DoubleItem x y) = ListItems [removeDoubles x, removeDoubles y]
removeDoubles x = defaultWalk removeDoubles x

removeTriples :: Item a -> Item a
removeTriples (TripleItem x y z) = ListItems [removeTriples x, removeTriples y, removeTriples z]
removeTriples x = defaultWalk removeTriples x

扩展性优化 #

如果后续给Item添加新的构造器，只需要更新defaultWalk函数，添加新构造器的默认处理逻辑即可，所有基于它的业务函数都会自动适配新结构，无需逐个修改。

如果需要在多个递归结构中复用这种模式，可以把defaultWalk抽象成类型类：

class RecursiveStructure t where
  defaultWalk :: (t a -> t a) -> t a -> t a

instance RecursiveStructure Item where
  defaultWalk f x@(Leaf _) = x
  defaultWalk f (ListItems xs) = ListItems $ f <$> xs
  defaultWalk f (DoubleItem x y) = DoubleItem (f x) (f y)
  defaultWalk f (TripleItem x y z) = TripleItem (f x) (f y) (f z)

方案二：使用Catamorphism（递归折叠） #

这是函数式编程中处理递归结构的通用模式，通过分离递归遍历逻辑和结构转换逻辑，彻底消除重复代码。

1. 定义基函子 #

首先把Item的递归结构拆分为基函子（描述非递归的结构形状）：

data ItemF a r =
    LeafF a
    | ListItemsF [r]
    | DoubleItemF r r
    | TripleItemF r r r
    deriving (Functor)

这里r代表递归位置的占位符，原来的Item a可以用Fix类型包装基函子得到：

newtype Fix f = Fix { unFix :: f (Fix f) }
type Item a = Fix (ItemF a)

2. 通用递归折叠函数 #

利用Functor实例，定义通用的catamorphism函数，它会自动处理递归遍历：

cata :: Functor f => (f b -> b) -> Fix f -> b
cata alg = alg . fmap (cata alg) . unFix

3. 编写结构转换代数 #

每个业务逻辑对应一个"代数"函数，只需要定义每个构造器的转换规则，无需手动处理递归：

-- removeDoubles对应的代数
removeDoublesAlg :: ItemF a (Item a) -> Item a
removeDoublesAlg (LeafF a) = Fix $ LeafF a
removeDoublesAlg (ListItemsF xs) = Fix $ ListItemsF xs
removeDoublesAlg (DoubleItemF x y) = Fix $ ListItemsF [x, y]
removeDoublesAlg (TripleItemF x y z) = Fix $ TripleItemF x y z

removeDoubles :: Item a -> Item a
removeDoubles = cata removeDoublesAlg

-- removeTriples对应的代数
removeTriplesAlg :: ItemF a (Item a) -> Item a
removeTriplesAlg (LeafF a) = Fix $ LeafF a
removeTriplesAlg (ListItemsF xs) = Fix $ ListItemsF xs
removeTriplesAlg (DoubleItemF x y) = Fix $ DoubleItemF x y
removeTriplesAlg (TripleItemF x y z) = Fix $ ListItemsF [x, y, z]

removeTriples :: Item a -> Item a
removeTriples = cata removeTriplesAlg

这种方式的优势在于：所有递归遍历逻辑都由cata统一处理，业务函数只需要关注结构转换规则；后续添加新构造器时，只需要更新ItemF和对应的代数函数，扩展性极强。

内容的提问来源于stack exchange，提问作者Chris J Harris