haskell - monadas - ¿Es posible extender intérpretes de mónada gratis?

monadas filosofia

Question

Dada una mónada DSL gratuita como:

data FooF x = Foo String x
            | Bar Int    x
  deriving (Functor)

type Foo = Free FooF

Y un intérprete al azar para Foo :

printFoo :: Foo -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n

Me parece que debería ser posible intercalar algo en cada iteración de printFoo sin tener que hacerlo manualmente:

printFoo'' :: Foo -> IO ()
printFoo'' (Free (Foo s n)) = print s >> print "extra info" >> printFoo'' n
printFoo'' (Free (Bar i n)) = print i >> print "extra info" >> printFoo'' n

¿Es esto posible de alguna manera ''envolviendo'' el printFoo original?

Motivación: Estoy escribiendo un DSL pequeño que se ''compila'' en un formato binario. El formato binario contiene información adicional después de cada comando de usuario. Tiene que estar allí, pero es totalmente irrelevante en mi caso de uso.

Answer 1

¿Estás buscando algo como esto?

Tu código original sería

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free

data FooF a = Foo String a | Bar Int a deriving (Functor)

type Foo = Free FooF

printFoo :: Show a => Foo a -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a)         = print a

Luego, puede definir una función de envoltura simple y un anotador recursivo que agrega la información adicional a cada capa de Foo (obviamente, esto puede ser tan complicado como desee).

annotate :: Foo a -> Foo a
annotate (Free (Foo s n)) = wrapper (Free (Foo s (annotate n)))
annotate (Free (Bar i n)) = wrapper (Free (Bar i (annotate n)))
annotate (Pure a)         = wrapper (Pure a)

wrapper :: Foo a -> Foo a
wrapper n = Free (Foo "Extra info" n)

Ahora define algunos constructores de conveniencia que definen tu DSL

foo :: String -> a -> Foo a
foo s a = Free (Foo s (Pure a))

bar :: Int -> a -> Foo a
bar i a = Free (Bar i (Pure a))

Lo que significa que puedes crear objetos Foo a a usando la interfaz de mónada y tu DSL.

example = do
    i <- return 1
    a <- foo "Created A" i
    b <- bar 123 a
    c <- foo "Created C" b
    return c

Ahora, si carga GHCI, puede trabajar con el example original o con la versión anotada.

>> printFoo example
"Created A"
123
"Created C"
1
>> printFoo (annotate example)
"Extra info"
"Created A"
"Extra info"
123
"Extra info"
"Created C"
"Extra info"
1

Answer 2

Ambas cosas simplemente atraviesan la estructura y acumulan el resultado del procesamiento inductivo. Esto requiere generalizar la iteración a través del catamorfismo.

> newtype Fix f = Fix {unFix :: f (Fix f)}
> data N a b x = Z a | S b x deriving (Functor)
> type Nat a b = Fix (N a b)
> let z = Fix . Z
> let s x = Fix . S x
> let x = s "blah" $ s "doo" $ s "duh" $ z 0
> let annotate (Z x) = s "annotate" $ z x;
      annotate (S x y) = s "annotate" $ s x y
> let exec (Z x) = print x; exec (S x y) = print x >> y
> let cata phi = phi . fmap (cata phi) . unFix
>
> cata exec x
"blah"
"doo"
"duh"
0
>
> cata exec $ cata annotate x
"annotate"
"blah"
"annotate"
"doo"
"annotate"
"duh"
"annotate"
0

Ahora permítanme explicar con más detalle lo que está sucediendo, ya que hubo algunos pedidos en los comentarios, y me preocupa que ya no sea una mónada, si uso Fix.

Considere el functor G:

G(X) = A + F(G(X))

Aquí F es un functor arbitrario. Entonces para cualquier A podemos encontrar un punto fijo (F y G son claramente polinomiales, estamos en Hask). Como asignamos cada objeto A de la categoría a un objeto de la categoría, estamos hablando de un funtor de puntos fijos, T (A). Resulta que es una mónada. Como es una mónada para cualquier functor F, T (A) es una mónada libre. (Verás que es obviamente una mónada del código de abajo)

{-# LANGUAGE DeriveFunctor
           , TypeSynonymInstances #-}

newtype Fix f = Fix {unFix :: f (Fix f)} -- the type of Fixed point of a functor
newtype Compo f g x = Compo {unCompo :: f (g x)} -- composition of functors

instance (Functor f, Functor g) => Functor (Compo f g) where -- composition of functors is a functor
  fmap f = Compo . fmap (fmap f) . unCompo

data FreeF a x = Pure a | Free x deriving (Functor) -- it is a bi-functor, really;
                -- this derives functor in x

-- a special case of fmap - the fmap with unwrapping; useful to eliminate pattern matching
ffmap :: (a -> b) -> FreeF b a -> b
ffmap f x = case fmap f x of -- unwrapping, since now distinction between Pure and Free is not important
              Pure a -> a
              Free a -> a

-- Free Monad is a functor of fixed points of functor G(X)
-- G(X) = A + F(G(X))
type Free f a = Fix (Compo (FreeF a) f) -- fixed point of composition F . (FreeF a)


-- unfortunately, when defined as type, (Free f a) cannot be declared
-- as a Monad (Free f) - Haskell wants Free f to be with `a`
-- instance Monad (Free f) where -- this derives a functor in a at the same time;
--                          note that fmap will work in x, and is not meant
--                          to be equal to (m >>= return . f), which is in `a`
--   return a = Fix $ Compo $ Pure a
--   (Fix (Compo (Pure a))) >>= f  = f a
--   (Fix (Compo (Free fx))) >>= f = Fix $ Compo $ Free $ fmap (>>= f) fx

ret :: (Functor f) => a -> Free f a -- yet it is a monad: this is return
ret = Fix . Compo . Pure

-- and this is >>= of the monad
bind :: (Functor f) => Free f a -> (a -> Free f b) -> Free f b
bind (Fix (Compo (Pure a))) f = f a
bind (Fix (Compo (Free fx))) f = Fix $ Compo $ Free $ fmap (`bind` f) fx

-- Free is done

-- here is your functor FooF
data FooF x = Z Int x | S String x deriving (Functor)

type Foo x = Free FooF x

-- catamorphism for an algebra phi "folds" any F(X) (represented by fixed point of F)
-- into X
cata :: (Functor f) => (f x -> x) -> Fix f -> x
cata phi = phi . fmap (cata phi) . unFix

-- helper functions to construct "Foo a"
z :: Int -> Foo a -> Foo a
z x = Fix . Compo . Free . Z x

s :: String -> Foo a -> Foo a
s x = Fix . Compo . Free . S x

tip :: a -> Foo a
tip = ret

program :: Foo (IO ())
program = s "blah" $ s "doo" $ s "duh" $ z 0 $ tip $ return ()

-- This is essentially a catamorphism; I only added a bit of unwrapping
cata'' :: (Functor f) => (f a -> a) -> Free f a -> a
cata'' phi = ffmap (phi . fmap (cata'' phi)) . unCompo . unFix

exec (Z x y) = print x >> y
exec (S x y) = print x >> y

annotate (Z x y) = s "annotated Z" $ z x y
annotate (S x y) = s "met S" $ s x y

main = do
         cata'' exec program
         cata'' exec $ cata'' annotate (program `bind` (ret . ret))
           -- cata'' annotate (program >>= return . return)
           -- or rather cata'' annotate $ fmap return program

program es Foo (IO ()) . fmap en a (recuerde que FreeF es un bi-functor: necesitamos fmap en a ) puede convertir el program en Foo (Foo (IO ())) - ahora el catamorfismo para anotado puede construir un nuevo Foo (IO ()) .

Tenga en cuenta que cata'' es iter de Control.Monad.Free .

Answer 3

Aquí hay una solución muy simple que utiliza el paquete operational : la alternativa razonable a las mónadas gratuitas.

Simplemente puede factorizar la función printFoo en una parte que imprime la instrucción propiamente dicha y una parte que agrega la información adicional, el tratamiento estándar para la duplicación de códigos como este.

{-# LANGUAGE GADTs #-}

import Control.Monad.Operational

data FooI a where
    Foo :: String -> FooI ()
    Bar :: Int    -> FooI ()

type Foo = Program FooI

printFoo :: Foo a -> IO a
printFoo = interpretWithMonad printExtra
    where
    printExtra :: FooI a -> IO a
    printExtra instr = do { a <- execFooI instr; print "extra info"; return a; }

execFooI :: FooI a -> IO a
execFooI (Foo s) = print s
execFooI (Bar i) = print i

Answer 4

Las otras respuestas han pasado por alto lo simple que hace esto free ! :) Actualmente tienes

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free

data FooF x = Foo String x
            | Bar Int    x
  deriving (Functor)

type Foo = Free FooF

program :: Free FooF ()
program = do
  liftF (Foo "Hello" ())
  liftF (Bar 1 ())
  liftF (Foo "Bye" ())

printFoo :: Foo () -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a) = return a

lo que da

*Main> printFoo program 
"Hello"
1
"Bye"

Eso está bien, pero iterM puede hacer la tubería necesaria para usted

printFooF :: FooF (IO a) -> IO a
printFooF (Foo s x) = print s >> x
printFooF (Bar i x) = print i >> x

printFooBetter :: Foo () -> IO ()
printFooBetter = iterM printFooF

Entonces conseguimos

*Main> printFooBetter program
"Hello"
1
"Bye"

OK genial, es lo mismo que antes. Pero printFooF nos da más flexibilidad para aumentar el traductor en las líneas que desee

printFooFExtra :: FooF (IO a) -> IO a
printFooFExtra = (print "stuff before IO action" >>)
                 . printFooF
                 . fmap (print "stuff after IO action" >>)

printFooExtra :: Foo () -> IO ()
printFooExtra = iterM printFooFExtra

entonces obtenemos

*Main> printFooExtra program
"stuff before IO action"
"Hello"
"stuff after IO action"
"stuff before IO action"
1
"stuff after IO action"
"stuff before IO action"
"Bye"
"stuff after IO action"

¡Gracias Gabriel González por popularizar las mónadas gratuitas y Edward Kmett por escribir la biblioteca! :)

Answer 5

Si está dispuesto a modificar ligeramente el intérprete original (cambiando la forma en que se maneja el caso del terminal)

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free
import Control.Monad.Morph
import Pipes

data FooF a = Foo String a | Bar Int a deriving (Functor)

printFoo :: Free FooF a -> IO a
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a)         = return a

... luego hay una manera de agregar acciones adicionales sin modificar el funtor o tener que reutilizar a sus constructores, mientras se puede reutilizar el intérprete.

La solución utiliza las pipes y los paquetes mmorph .

Primero tienes que definir una especie de "pre-intérprete" que levanta la mónada libre a un Producer desde las pipes . Las declaraciones de yield () en el productor representan los puntos en los que se inserta una acción adicional.

pre :: Free FooF a -> Producer () (Free FooF) a
pre (Free (Foo s n)) = lift (Free . Foo s $ return ()) >> yield () >> pre n
pre (Free (Bar i n)) = lift (Free . Bar i $ return ()) >> yield () >> pre n
pre (Pure a)         = lift . Pure $ a 

(En un ejemplo más complejo, las declaraciones de yield podrían llevar información adicional, como los mensajes de registro).

Luego escribe una función que aplica el intérprete de printFoo debajo del Producer , utilizando hoist from mmorph :

printFooUnder :: Producer () (Free FooF) a -> Producer () IO a
printFooUnder = hoist printFoo

Entonces, tenemos una función que "interpreta" la mónada libre en IO , pero en algunos puntos emite () valores que debemos decidir cómo manejarlos.

Ahora podemos definir un intérprete extendido que reutiliza el intérprete antiguo:

printFooWithReuse :: Show a => Free FooF a -> IO () 
printFooWithReuse foo = do
    finalv <- runEffect $ for (printFooUnder . pre $ foo) 
                              (/_ -> lift (print "extra info"))
    print finalv

Después de probarlo, parece funcionar:

printFooWithReuse $ Free (Foo "nah" (Pure 4))
-- > "nah"
-- > "extra info"
-- > 4

Si desea insertar las acciones adicionales manualmente, puede evitar escribir el "pre-intérprete" y trabajar directamente en la mónada Producer () (Free FooF) .

(Esta solución también podría lograrse mediante la colocación en capas de un transformador de mónada libre en lugar de un Producer . Pero creo que usar un Producer es un poco más fácil).