Procesando árboles con esquemas de recursión

Hace mucho tiempo, estuve en contacto con un sistema en producción cuyo propósito era pasar un dato a través de un árbol de decisiones. En cada paso, la salida podía ser Bueno, Malo, Mover a la Izquierda o Mover a la Derecha; no había hojas, ya que al final siempre se suponía que debías haber retornado Bueno o Malo (lo que significa que llegar allí sería un error).

Los nodos del árbol de decisiones podían ser prácticamente cualquier cosa: la mayoría eran reglas de expertos para determinar ciertos casos y marcarlos automáticamente como buenos o malos; otros eran modelos cuidadosamente diseñados. Algunos de estos nodos también requerían acceso a APIs internas para obtener más datos sobre lo que se estaba procesando.

Operaba en un entorno que cambiaba frecuentemente, lo que significaba que los patrones que el árbol buscaba tenían que adaptarse constantemente, y por eso era un requisito del sistema poder hacer hotswap del código de los nodos.

El sistema no era capaz de hacer hotswapping, por las razones que fuera (no soy experto en Java, pero parece que hay varias formas de hacerlo). Esto llevó a alguien a crear su propio lenguaje de scripting.

El lenguaje en sí era bastante malo, pero lo que tenía de bueno era que estaba muy bien integrado: también habían construido control de versiones sobre el código de los nodos, y el despliegue era razonablemente fluido si trabajabas con ese tipo de nodos.

El problema surgía cuando querías hacer algo con los nodos que no estaba soportado dentro del lenguaje de scripting, como acceder a APIs. En esos casos, tenías que entrar en cada servidor que tenía el código, reemplazar las clases Java compiladas con el código de tu nuevo nodo, y luego reiniciar el servidor para que detectara el nuevo código. No hace falta decir que era un dolor de cabeza y, por supuesto, muy propenso a errores.

Hace unos días, estaba leyendo la Introducción a los Esquemas de Recursión de Patrick Thomson  y este problema volvió a mi mente. Pensé que podría ser un buen ejercicio para aprender esquemas de recursión; y así llegamos hasta acá. Antes de empezar, puede que quieras leer al menos los primeros uno o dos artículos de los tutoriales de Patrick. Además, voy a usar la librería recursion-schemes de Edward Kmett a lo largo de todo esto, junto con varias extensiones del lenguaje y demás; podés ver el código terminado en mi repositorio de GitHub .

Para empezar, tendremos nuestro árbol (Tree):

import qualified Data.Functor.Foldable.TH as R

data Tree a
  = Node { value :: !a
         , left  :: Tree a
         , right :: Tree a }
  | Failure
  deriving (Functor, Foldable, Traversable, Show)

R.makeBaseFunctor ''Tree

Observación: este tipo te permite escribir árboles que nunca terminan. No tenemos forma de protegernos contra esto en el sistema de tipos (que yo sepa), pero definitivamente podés pedir que left y right sean estrictos, lo que significaría que cualquier programa de ese tipo se colgaría en el momento en que intentés construir ese valor, creo.

Esta llamada a makeBaseFunctor garantiza que obtengamos el tipo adicional TreeF con los «agujeros de continuación» para el tipo. Y luego tendremos dos tipos cruciales:

data Movement
  = L
  | R
  deriving (Show, Eq, Ord, Enum)

type Outcome d = Either d Movement

Así es como vamos a codificar la salida de un nodo: cada nodo tiene que producir un valor de tipo Outcome d, y simplemente verificaremos si es un movimiento o un valor de salida que acaba de producirse. Por lo tanto, el tipo de lo que produce un resultado (que voy a llamar Rule porque es el nombre que más sentido me hace ahora mismo) es bastante claro:

type Rule m d = m (Outcome d)

Donde tendremos una restricción en la que requerimos que m sea una instancia de Monad. Este tipo, aunque bastante simple, nos dará toda la flexibilidad que necesitamos: Tree (Rule m d) tiene acciones monádicas en cada nodo; cuando ejecutemos la acción monádica, obtendremos un Outcome d, que podemos examinar para decidir qué hacer a continuación.

Con estos tipos, la función que necesitamos tendrá una firma que se ve así:

execute :: (Monad m) => Tree (Rule m d) -> m (Outcome d)

Casi. Podrías llegar a un nodo Failure, y por lo tanto no hay forma de que puedas producir un Outcome d, lo que significa que te verías forzado a lanzar un error de alguna otra manera. Como usar la función fail de la instancia Monad se considera una mala práctica, simplemente opté por esto:

execute :: (MonadCatch m) => Tree (Rule m d) -> m (Outcome d)

Hay todavía otro problema con esta firma de función: si el Rule lanza una excepción, el proceso completo se interrumpirá; y no podremos distinguir entre un error en la ejecución y un error en la regla (al menos no a priori). Por eso, introduje otra abstracción más, que es la de un Execution:

newtype Execution d = Execution
  { _result :: Either SomeException (Outcome d)
  } deriving (Show)

Lens.makeLenses ''Execution

failed :: Execution d -> Bool
failed = isLeft . (^. result)

outcome :: Execution d -> Outcome d
outcome = fromRight undefined . (^. result)

apply :: (MonadCatch m) => Rule m d -> m (Execution d)
apply rule =
  do outcome <- rule
     return Execution {_result = Right outcome}
     `catch` \exception -> return Execution {_result = Left exception}

destruct ::
     (SomeException -> a) -> (d -> a) -> (Movement -> a) -> Execution d -> a
destruct e d m execution =
  case execution ^. result of
    Left exception -> e exception
    Right outcome ->
      case outcome of
        Left decision -> d decision
        Right move -> m move

En efecto, un Execution es simplemente el resultado de ejecutar una Rule. Además, un execute con una firma como la anterior no podrá proporcionar ninguna información de depuración: no tenemos conocimiento del camino que se tomó en el árbol. La manera fácil de resolver esto es simplemente emitir un Tree:

execute :: (MonadCatch m)
  => Tree (Rule m d)
  -> m (Tree (Execution d))

La pregunta ahora es qué esquema de recursión usar. Al principio pensé que sería un catamorfismo, sin embargo, simplemente no lo es, porque el proceso que queremos llevar a cabo es «primero ejecutar la regla, luego tomar una decisión sobre hacia dónde ir», lo cual es diferente de «ejecutar las reglas de los dos lados, luego decidir qué hacer con la regla actual».

Después de mucho tiempo mirando las firmas de tipo, quedó claro que es un anamorfismo. La forma en que me gusta pensarlo es que, en cada paso, hay que desplegar un nuevo Tree; esto requiere que proveas el value para el Node, y sus dos lados. El value corresponde al Execution d, y los dos lados dependen de la ejecución de la regla: si la regla indicó terminar, entonces ambos lados son Failure; si indicó ir L, entonces solo el lado right es Failure mientras que el lado left contiene el próximo Rule m d a ejecutar (el otro caso es simétrico). Por lo tanto, necesitamos una transformación de tipo:

go :: (MonadCatch m)
  => Tree (Rule m d)
  -> m (TreeF (Execution d) (Tree (Rule m d)))

Codificar esto es una tarea bastante sencilla, siempre que se cuente con un anamorfismo monádico. Esto no es tan simple como parece porque hay que elegir algún orden para los efectos del Monad. Hay un bug cerrado antiguo  en el repositorio de GitHub de recursion-schemes con una discusión sobre las complejidades. Simplemente usé la definición de anaM del primer comentario:

anaM :: (Monad m, Corecursive b, Traversable (Base b))
  => (a -> m (Base b a))
  -> a
  -> m b
anaM coalg = recurse
  where
    recurse = (return . embed) <=< mapM recurse <=< coalg

Con algo de código adicional, resulta ser muy sencillo escribir esta función:

deadendF ::a -> b -> TreeF a b
deadendF a b = NodeF a b b

conditionalF :: a -> Tree b -> Movement -> TreeF a (Tree b)
conditionalF x branch L = NodeF {valueF = x, leftF = branch, rightF = Failure}
conditionalF x branch R = NodeF {valueF = x, leftF = Failure, rightF = branch}

branch :: Movement -> Tree a -> Tree a
branch L = left
branch R = right

execute :: (MonadCatch m)
  => Tree (Rule m d)
  -> m (Tree (Execution d))
execute = anaM go
  where
    go Failure = return FailureF
    go tree@Node {value = rule} = do
      !execution <- apply rule
      let endpoint = const $ deadendF execution Failure
      return $ destruct endpoint endpoint
        (\move -> conditionalF execution (branch move tree) move)
        execution