Аннотация Haskell AST с исправлением

Изменить. Добавьте пример функции для ProgramFs с общими аннотациями.

Да, по крайней мере, в случае с 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 ()

где «U» в ProgramU означает «единица измерения». Очевидно, вы можете легко написать трансляторы для работы с Programs как ProgramUs, если это действительно необходимо:

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

В качестве конкретного — хотя и глупого — примера, вот функция, которая разделяет Lets с несколькими привязками на вложенные Lets с одноэлементными привязками (и, таким образом, разрывает взаимно рекурсивные привязки в языке Program). Предполагается, что аннотация к мультипривязке 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