Como reduzir a duplicação de código ao lidar com tipos de soma recursiva

Atualmente, estou trabalhando em um intérprete simples para uma linguagem de programação e tenho um tipo de dados como este:

data Expr
  = Variable String
  | Number Int
  | Add [Expr]
  | Sub Expr Expr

E eu tenho muitas funções que fazem coisas simples como:

-- Substitute a value for a variable
substituteName :: String -> Int -> Expr -> Expr
substituteName name newValue = go
  where
    go (Variable x)
      | x == name = Number newValue
    go (Add xs) =
      Add $ map go xs
    go (Sub x y) =
      Sub (go x) (go y)
    go other = other

-- Replace subtraction with a constant with addition by a negative number
replaceSubWithAdd :: Expr -> Expr
replaceSubWithAdd = go
  where
    go (Sub x (Number y)) =
      Add [go x, Number (-y)]
    go (Add xs) =
      Add $ map go xs
    go (Sub x y) =
      Sub (go x) (go y)
    go other = other

Mas em cada uma dessas funções, tenho que repetir a parte que chama o código recursivamente com apenas uma pequena alteração em uma parte da função. Existe alguma maneira de fazer isso de maneira mais genérica? Prefiro não ter que copiar e colar esta parte:

    go (Add xs) =
      Add $ map go xs
    go (Sub x y) =
      Sub (go x) (go y)
    go other = other

E apenas mude um único caso de cada vez, porque parece ineficiente duplicar código como este.

A única solução que eu poderia encontrar é ter uma função que chame uma função primeiro em toda a estrutura de dados e depois recursivamente no resultado da seguinte forma:

recurseAfter :: (Expr -> Expr) -> Expr -> Expr
recurseAfter f x =
  case f x of
    Add xs ->
      Add $ map (recurseAfter f) xs
    Sub x y ->
      Sub (recurseAfter f x) (recurseAfter f y)
    other -> other

substituteName :: String -> Int -> Expr -> Expr
substituteName name newValue =
  recurseAfter $ \case
    Variable x
      | x == name -> Number newValue
    other -> other

replaceSubWithAdd :: Expr -> Expr
replaceSubWithAdd =
  recurseAfter $ \case
    Sub x (Number y) ->
      Add [x, Number (-y)]
    other -> other

Mas sinto que provavelmente já deveria haver uma maneira mais simples de fazer isso. Estou esquecendo de algo?

Parabéns, você acabou de descobrir os anamorfismos!

Aqui está o seu código, reformulado para que funcione com o recursion-schemespacote. Infelizmente, não é mais curto, pois precisamos de um padrão para fazer as máquinas funcionarem. (Pode haver alguma maneira automagica de evitar o clichê, por exemplo, usando genéricos. Eu simplesmente não sei.)

Abaixo, o seu recurseAfteré substituído pelo padrão ana.

Primeiro, definimos seu tipo recursivo, bem como o functor no qual é o ponto fixo.

{-# LANGUAGE DeriveFunctor, TypeFamilies, LambdaCase #-}
{-# OPTIONS -Wall #-}
module AnaExpr where

import Data.Functor.Foldable

data Expr
  = Variable String
  | Number Int
  | Add [Expr]
  | Sub Expr Expr
  deriving (Show)

data ExprF a
  = VariableF String
  | NumberF Int
  | AddF [a]
  | SubF a a
  deriving (Functor)

Em seguida, conectamos os dois com algumas instâncias para que possamos nos desdobrar Exprno isomórfico ExprF Expre dobrá-lo para trás.

type instance Base Expr = ExprF
instance Recursive Expr where
   project (Variable s) = VariableF s
   project (Number i) = NumberF i
   project (Add es) = AddF es
   project (Sub e1 e2) = SubF e1 e2
instance Corecursive Expr where
   embed (VariableF s) = Variable s
   embed (NumberF i) = Number i
   embed (AddF es) = Add es
   embed (SubF e1 e2) = Sub e1 e2

Por fim, adaptamos seu código original e adicionamos alguns testes.

substituteName :: String -> Int -> Expr -> Expr
substituteName name newValue = ana $ \case
    Variable x | x == name -> NumberF newValue
    other                  -> project other

testSub :: Expr
testSub = substituteName "x" 42 (Add [Add [Variable "x"], Number 0])

replaceSubWithAdd :: Expr -> Expr
replaceSubWithAdd = ana $ \case
    Sub x (Number y) -> AddF [x, Number (-y)]
    other            -> project other

testReplace :: Expr
testReplace = replaceSubWithAdd 
   (Add [Sub (Add [Variable "x", Sub (Variable "y") (Number 34)]) (Number 10), Number 4])

Uma alternativa poderia ser definir ExprF aapenas e derivar type Expr = Fix ExprF. Isso economiza parte do clichê acima (por exemplo, as duas instâncias), ao custo de ter que usar em Fix (VariableF ...)vez de Variable ..., bem como o análogo para os outros construtores.

Pode-se aliviar ainda mais o uso de sinônimos de padrão (ao custo de um pouco mais de clichê).

Atualização: Finalmente encontrei a ferramenta automagic, usando o modelo Haskell. Isso torna o código inteiro razoavelmente curto. Observe que o ExprFfunctor e as duas instâncias acima ainda existem sob o capô, e ainda precisamos usá-los. Só economizamos o trabalho de defini-los manualmente, mas isso economiza muito esforço.

{-# LANGUAGE DeriveFunctor, DeriveTraversable, TypeFamilies, LambdaCase, TemplateHaskell #-}
{-# OPTIONS -Wall #-}
module AnaExpr where

import Data.Functor.Foldable
import Data.Functor.Foldable.TH

data Expr
  = Variable String
  | Number Int
  | Add [Expr]
  | Sub Expr Expr
  deriving (Show)

makeBaseFunctor ''Expr

substituteName :: String -> Int -> Expr -> Expr
substituteName name newValue = ana $ \case
    Variable x | x == name -> NumberF newValue
    other                  -> project other

testSub :: Expr
testSub = substituteName "x" 42 (Add [Add [Variable "x"], Number 0])

replaceSubWithAdd :: Expr -> Expr
replaceSubWithAdd = ana $ \case
    Sub x (Number y) -> AddF [x, Number (-y)]
    other            -> project other

testReplace :: Expr
testReplace = replaceSubWithAdd 
   (Add [Sub (Add [Variable "x", Sub (Variable "y") (Number 34)]) (Number 10), Number 4])

Como uma abordagem alternativa, este também é um caso de uso típico para o uniplatepacote. Ele pode usar Data.Datagenéricos em vez do Template Haskell para gerar o padrão, portanto, se você der Dataexemplos para o seu Expr:

import Data.Data

data Expr
  = Variable String
  | Number Int
  | Add [Expr]
  | Sub Expr Expr
  deriving (Show, Data)

a transformfunção from Data.Generics.Uniplate.Dataaplica uma função recursivamente a cada aninhado Expr:

import Data.Generics.Uniplate.Data

substituteName :: String -> Int -> Expr -> Expr
substituteName name newValue = transform f
  where f (Variable x) | x == name = Number newValue
        f other = other

replaceSubWithAdd :: Expr -> Expr
replaceSubWithAdd = transform f
  where f (Sub x (Number y)) = Add [x, Number (-y)]
        f other = other

Observe que, replaceSubWithAddem particular, a função fé escrita para executar uma substituição não recursiva; transformtorna a entrada recursiva x :: Expr, fazendo a mesma mágica para a função auxiliar anaque na resposta do @ chi:

> substituteName "x" 42 (Add [Add [Variable "x"], Number 0])
Add [Add [Number 42],Number 0]
> replaceSubWithAdd (Add [Sub (Add [Variable "x", 
                     Sub (Variable "y") (Number 34)]) (Number 10), Number 4])
Add [Add [Add [Variable "x",Add [Variable "y",Number (-34)]],Number (-10)],Number 4]
> 

Isso não é mais curto que a solução Template Haskell da @ chi. Uma vantagem potencial é que uniplatefornece algumas funções adicionais que podem ser úteis. Por exemplo, se você usar descendno lugar de transform, ele transforma apenas os filhos imediatos, que podem lhe dar controle sobre onde a recursão ocorre ou você pode usar rewritepara refazer a transformação do resultado das transformações até atingir um ponto fixo. Uma desvantagem potencial é que o "anamorfismo" parece muito mais legal do que o "uniplate".

Programa completo:

{-# LANGUAGE DeriveDataTypeable #-}

import Data.Data                     -- in base
import Data.Generics.Uniplate.Data   -- package uniplate

data Expr
  = Variable String
  | Number Int
  | Add [Expr]
  | Sub Expr Expr
  deriving (Show, Data)

substituteName :: String -> Int -> Expr -> Expr
substituteName name newValue = transform f
  where f (Variable x) | x == name = Number newValue
        f other = other

replaceSubWithAdd :: Expr -> Expr
replaceSubWithAdd = transform f
  where f (Sub x (Number y)) = Add [x, Number (-y)]
        f other = other

replaceSubWithAdd1 :: Expr -> Expr
replaceSubWithAdd1 = descend f
  where f (Sub x (Number y)) = Add [x, Number (-y)]
        f other = other

main = do
  print $ substituteName "x" 42 (Add [Add [Variable "x"], Number 0])
  print $ replaceSubWithAdd e
  print $ replaceSubWithAdd1 e
  where e = Add [Sub (Add [Variable "x", Sub (Variable "y") (Number 34)])
                     (Number 10), Number 4]