带修复的 Haskell AST 注释

Question

我正在努力在 Haskell 中创建一个 AST。我想添加不同的注释，例如类型和位置信息，所以我最终使用了 fixplate .但是，我在网上找不到任何示例并且遇到了一些困难。

我已经按照 fixplate 的建议设置了我的 AST(有些被删除了):

data ProgramF a
  = Unary a
          Operator
  | Number Int
  | Let { bindings :: [(Identifier, a)]
        , body :: a }

type Program = Mu ProgramF

接下来添加一个标签，我创建了另一种类型，以及一个基于树遍历添加标签的函数。

type LabelProgram = Attr ProgramF PLabel

labelProgram :: Program -> LabelProgram
labelProgram =
  annMap (PLabel . show . fst) . (snd . synthAccumL (\i x -> (i + 1, (i, x))) 0)

但是，除此之外，我遇到了一些问题。例如，我正在尝试编写一个对 AST 进行一些转换的函数。因为它需要一个标签才能起作用，所以我将类型设为 LabelProgram -> Program ，但我认为我在这里做错了什么。下面是部分函数的片段(其中一个更简单的部分):

toANF :: LabelProgram -> Program
toANF (Fix (Ann label (Let {bindings, body}))) = Fix $ Let bindingANF nbody
  where
    bindingANF = map (\(i, e) -> (i, toANF e)) bindings
    nbody = toANF body

我觉得我在这里工作的抽象级别错误。我是否应该明确匹配 Fix Ann ...并返回 Fix ...像这样，还是我用错了固定板？

此外，我担心如何泛化函数。如何使我的函数适用于 Program年代， LabelProgram s 和 TypeProgram一般情况下？

Answer 1

编辑:为 ProgramF 添加一个函数示例s 带有通用注释。

是的，至少在 toANF 的情况下，你用错了。

在 toANF ，请注意您的 Let bindingANF nbody以及 bindingANF 的伴随定义和 nbody只是 fmap toANF 的重新实现对于具体的构造函数Let .

也就是说，如果您导出 Functor您的 ProgramF 的实例，然后你可以重写你的toANF片段为:

toANF :: LabelProgram -> Program
toANF (Fix (Ann label l@(Let _ _))) = Fix (fmap toANF l)

如果 toANF只是剥离标签，那么这个定义适用于所有构造函数，而不仅仅是 Let ，因此您可以删除模式:

toANF :: LabelProgram -> Program
toANF (Fix (Ann label l)) = Fix (fmap toANF l)

现在，根据@Regis_Kuckaertz 的评论，您刚刚重新实现了 forget定义为:

forget = Fix . fmap forget . unAnn . unFix

关于编写在 Program 上通用的函数, LabelProgram等，我认为在(单个)注释中编写泛型函数更有意义:

foo :: Attr ProgramF a -> Attr ProgramF a

并且，如果您确实需要将它们应用于未注释的程序，请定义:

type ProgramU = Attr ProgramF ()

ProgramU 中的“U”代表“单位”。显然，您可以轻松编写翻译器来使用 Program s 为 ProgramU s 如果真的需要:

toU :: Functor f => Mu f -> Attr f ()
toU = synthetise (const ())

fromU :: Functor f => Attr f () -> Mu f
fromU = forget

mapU :: (Functor f) => (Attr f () -> Attr f ()) -> Mu f -> Mu f
mapU f = fromU . f . toU

foo' :: Mu ProgramF -> Mu ProgramF
foo' = mapU foo

作为一个具体的——如果愚蠢的话——示例，这里有一个分隔 Let 的函数。 s 具有多个绑定(bind)到嵌套 Let s 与单例绑定(bind)(因此打破了 Program 语言中的相互递归绑定(bind))。它假定多绑定(bind) Let 上的注释将被复制到每个生成的单例 Let年代:

splitBindings :: Attr ProgramF a -> Attr ProgramF a
splitBindings (Fix (Ann a (Let (x:y:xs) e)))
  = Fix (Ann a (Let [x] (splitBindings (Fix (Ann a (Let (y:xs) e))))))
splitBindings (Fix e) = Fix (fmap splitBindings e)

可以应用于示例 Program :

testprog :: Program
testprog = Fix $ Unary (Fix $ Let [(Identifier "x", Fix $ Number 1), 
                                   (Identifier "y", Fix $ Number 2)] 
                                  (Fix $ Unary (Fix $ Number 3) NegOp))
                       NegOp

像这样:

> mapU splitBindings testprog
Fix (Unary (Fix (Let {bindings = [(Identifier "x",Fix (Number 1))],
body = Fix (Let {bindings = [(Identifier "y",Fix (Number 2))], 
body = Fix (Unary (Fix (Number 3)) NegOp)})})) NegOp)
>

这是我的完整工作示例:

{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wall #-}

import Data.Generics.Fixplate

data Identifier = Identifier String deriving (Show)
data PLabel = PLabel deriving (Show)
data Operator = NegOp deriving (Show)

data ProgramF a
  = Unary a
          Operator
  | Number Int
  | Let { bindings :: [(Identifier, a)]
        , body :: a }
  deriving (Show, Functor)
instance ShowF ProgramF where showsPrecF = showsPrec

type Program = Mu ProgramF
type LabelProgram = Attr ProgramF PLabel

splitBindings :: Attr ProgramF a -> Attr ProgramF a
splitBindings (Fix (Ann a (Let (x:y:xs) e)))
  = Fix (Ann a (Let [x] (splitBindings (Fix (Ann a (Let (y:xs) e))))))
splitBindings (Fix e) = Fix (fmap splitBindings e)

toU :: Functor f => Mu f -> Attr f ()
toU = synthetise (const ())

fromU :: Functor f => Attr f () -> Mu f
fromU = forget

mapU :: (Functor f) => (Attr f () -> Attr f ()) -> Mu f -> Mu f
mapU f = fromU . f . toU

testprog :: Program
testprog = Fix $ Unary (Fix $ Let [(Identifier "x", Fix $ Number 1), 
                                   (Identifier "y", Fix $ Number 2)] 
                                  (Fix $ Unary (Fix $ Number 3) NegOp))
                       NegOp

main :: IO ()
main = print $ mapU splitBindings testprog