为Cofree标注AST扩展左扫描：解决scanCofree无作用问题

背景：玫瑰树的并行扫描（正常工作） #

你实现的玫瑰树扫描是并行扫描：父节点计算累积值后，所有子节点共享该值作为初始状态，逻辑正确：

data Tree a = Node a [Tree a] deriving (Show)

scan :: (b -> a -> b) -> b -> Tree a -> Tree b
scan f a (Node x ns) = Node a' $ map (scan f a') ns
  where
    a' = f a x

t0 :: Tree Int
t0 = Node 3 [Node 5 [], Node 1 []]

运行结果：

> scan (+) 0 t0
Node 3 [Node 8 [],Node 4 []]

你的Cofree扫描实现 #

你参照玫瑰树逻辑实现了scanCofree，但它同样是并行扫描逻辑：

data Cofree f a = a :< f (Cofree f a)

scanCofree :: Functor f => (b -> a -> b) -> b -> Cofree f a -> Cofree f b
scanCofree f a (x :< ns) = a' :< fmap (scanCofree f a') ns
  where
    a' = f a x

命令式语言Stmt的定义与问题现象 #

你定义了带赋值、序列、分支的Stmt类型（注：原定义存在冗余参数错误，后文修正），并通过annotate给每个节点标注当前语句新增的变量绑定：

-- 原错误定义（存在冗余a参数）
data Stmt a = SAssign Int | SSeq [Stmt a] | SIf (Stmt a) (Stmt a) deriving (Show)

-- 标注函数：给每个节点标注新增的绑定
binds :: Stmt a -> Cofree (StmtF a) [Id]
binds = annotate f
  where
    f = \case
      SAssign i -> [i]
      _ -> []

s0 = SSeq [SAssign 0,SIf (SAssign 1) (SAssign 2)]

运行后发现，scanCofree (<>) mempty调用后结果无变化：

> binds s0 
[] :< SSeqF [[0] :< SAssignF 0,[] :< SIfF ([1] :< SAssignF 1) ([2] :< SAssignF 2)]

> scanCofree (<>) mempty $ binds s0
[] :< SSeqF [[0] :< SAssignF 0,[] :< SIfF ([1] :< SAssignF 1) ([2] :< SAssignF 2)]

你期望的结果是顺序累积作用域，即SAssign0的绑定传递给后续的SIf分支：

[] :< SSeqF [[0] :< SAssignF 0,[] :< SIfF ([0,1] :< SAssignF 1) ([0,2] :< SAssignF 2)]

问题根源 #

1. 并行扫描与顺序语义不匹配：你的scanCofree是并行逻辑，所有子节点共享父节点的初始累积值。但SSeq是顺序执行结构，需要前一个语句的累积结果传递给后一个语句，而非共享初始值。

   • 根节点SSeq的累积值是mempty <> [] = []，所有子节点都从[]开始扫描
   • SIf节点的累积值是[] <> [] = []，它的子节点也从[]开始，所以结果和原标注一致

2. Stmt类型定义冗余：原Stmt a和StmtF a x中的a参数未被使用，属于冗余定义，会导致类型逻辑混乱。

解决方法 #

步骤1：修正Stmt类型定义 #

使用递归方案的标准固定点定义，去掉冗余参数：

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell #-}

import Data.Functor.Foldable (Fix(..), Recursive(..), Corecursive(..))
import Text.Show.Deriving (deriveShow1)

-- Stmt的基函子
data StmtF x = SAssignF Id | SSeqF [x] | SIfF x x
  deriving (Eq, Show, Functor, Foldable, Traversable)
$(deriveShow1 ''StmtF)

-- 用Fix定义Stmt
type Stmt = Fix StmtF

-- 递归实例
instance Recursive Stmt where
  project = unFix

instance Corecursive Stmt where
  embed = Fix

-- 标注函数：给每个节点标注新增的绑定
annotate :: Recursive t => (t -> a) -> t -> Cofree (Base t) a
annotate alg t = alg t :< fmap (annotate alg) (project t)

binds :: Stmt -> Cofree StmtF [Id]
binds = annotate f
  where
    f :: Stmt -> [Id]
    f (Fix (SAssignF i)) = [i]
    f _ = []

-- 测试用例
s0 :: Stmt
s0 = Fix $ SSeqF [Fix (SAssignF 0), Fix $ SIfF (Fix (SAssignF 1)) (Fix (SAssignF 2))]

步骤2：定制顺序+并行的扫描函数 #

针对StmtF的结构，实现同时支持顺序序列扫描和并行分支扫描的scanCofreeStmt：

import Data.Monoid

-- 定制Cofree扫描：顺序处理SSeq，并行处理SIf
scanCofreeStmt :: Monoid b => (b -> [Id] -> b) -> b -> Cofree StmtF [Id] -> Cofree StmtF b
scanCofreeStmt f initScope (newBinds :< stmtF) =
  let currentScope = f initScope newBinds
  in currentScope :< case stmtF of
       SAssignF i -> SAssignF i
       SSeqF children -> SSeqF (scanSeq children currentScope)
       SIfF left right -> SIfF (scanCofreeStmt f currentScope left) (scanCofreeStmt f currentScope right)
  where
    -- 顺序扫描序列，传递作用域
    scanSeq [] _ = []
    scanSeq (child:rest) scope =
      let scannedChild = scanCofreeStmt f scope child
          nextScope = case scannedChild of (s :< _) -> s
      in scannedChild : scanSeq rest nextScope

步骤3：测试验证 #

调用scanCofreeStmt (<>) mempty $ binds s0，得到符合预期的结果：

[] :< SSeqF [[0] :< SAssignF 0,[0] :< SIfF ([0,1] :< SAssignF 1) ([0,2] :< SAssignF 2)]

• 根节点SSeq的作用域为空（自身无新增绑定）
• SAssign0的作用域：[] <> [0] = [0]
• SIf的作用域：继承前一个语句的[0]，自身无新增绑定，所以是[0]
• SIf分支中的SAssign1/2：作用域为[0] <> [1] = [0,1]和[0] <> [2] = [0,2]

补充说明 #

如果你希望节点标注保留新增绑定，而仅让子节点累积作用域，可修改扫描逻辑，不替换当前节点的标注，仅传递状态给子节点，但这不属于标准的左扫描语义。

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