Free Monad (ou pas) en Haskell (2)

Voir aussi : video youtube - code source

Le post précédent donnait des définitions, intuitions et exemples à propos des free monads. On va maintenant voir comment combiner des free monads.

Exemple avec Free + Sum

Dans le post précédent, on avait implémenté un EDSL de système de fichiers (lister les fichiers, créer un dossier, supprimer un dossier). On veut désormais ajouter un système de logs pour pouvoir écrire des messages d’information dans une application, voire dans l’interprétation de l’EDSL. Dans un premier temps, voyons comment faire ça avec des free monads classiques.

Modèle

Comme pour le foncteur FilesF et la free monad Files, on définit notre système de log avec un foncteur LogF, une free monad Log et une fonction primitive logPut :

data LogF a
  = LogPut String a
  deriving (Functor)

type Log = Free LogF

logPut :: String -> Log ()
logPut msg = liftF $ LogPut msg ()

data FilesF a
...

Combiner les deux free monads

On a donc deux free monads Log et Files, qu’on peut utiliser indépendamment. On voudrait également pouvoir écrire des applications qui utilisent ces deux free monads à la fois.

Pour cela, on peut définir un foncteur Sum, contenant deux autres foncteurs. En fait, ce type Sum est déjà défini, dans le module Data.Functor.Sum, de la façon suivante :

data Sum f g a 
  = InL (f a) 
  | InR (g a) 
  deriving (Functor)

Ainsi, le type Sum LogF FilesF est un foncteur qui regroupe les fonctionnalités de LogF et de FilesF. On peut alors définir la free monad LogFiles correspondante :

type LogFiles = Free (Sum LogF FilesF)

Pour pouvoir accéder aux fonctionnalités de Log ou de Files dans LogFiles, on peut écrire les deux fonctions de transformations, left et right, suivantes :

left :: (Functor f, Functor g) => Free f a -> Free (Sum f g) a
left = hoistFree InL

right :: (Functor f, Functor g) => Free g a -> Free (Sum f g) a
right = hoistFree InR

Applications

On peut maintenant utiliser chacune des free monads précédentes. Par exemple, l’application app1 suivante utilise uniquement Log :

app1 :: Log ()
app1 = do
  logPut "hello"
  logPut "world"

Si on veut utiliser à la fois Log et Files, on utilise la free monad LogFiles et on accède aux fonctionnalités de Log et de Files via left et right :

app2 :: LogFiles ()
app2 = do
  right $ filesMkdir "output1"
  files <- right filesLs
  right $ filesRmdir "output1"
  left $ logPut $ show files

Interpréteurs

Il reste à écrire les interpréteurs. Par exemple, un interpréteur de Log qui affiche les messages à l’écran :

runLogVerbose :: LogF a -> IO a
runLogVerbose (LogPut str next) = do
  putStrLn ("[Log] " ++ str)
  return next

Un interpréteur de Log qui n’affiche pas les messages :

runLogQuiet :: LogF a -> IO a
runLogQuiet (LogPut _str next) = do
  return next

Un interpréteur de Files qui réalise réellement les opérations sur le système de fichiers :

runFilesFs :: FilesF a -> IO a
runFilesFs (FilesLs next) = do
  putStrLn "running filesLs"
  files <- listDirectory "."
  return $ next files
runFilesFs (FilesMkdir fp next) = do
  putStrLn "running filesMkdir"
  createDirectory fp
  return next
runFilesFs (FilesRmdir fp next) = do
  putStrLn "running filesRmdir"
  removeDirectory fp
  return next

Enfin pour interpréter LogFiles, on peut écrire la fonction runSum suivante, qui permettra de combiner un interpréteur de Log avec un interpréteur de Files :

runSum :: (f a -> t a) -> (g a -> t a) -> Sum f g a -> t a
runSum runL _    (InL x) = runL x
runSum _    runR (InR x) = runR x

Exécution

L’application app1 utilise uniquement la free monad Log. On peut donc l’exécuter avec les interpréteurs de Log, par exemple runLogVerbose :

*Main> foldFree runLogVerbose app1
[Log] hello
[Log] world

Pour app2, on utilise la free monad LogFiles, donc on peut combiner deux interpréteurs avec runSum. Par exemple, runLogQuiet et runFilesFs :

*Main> foldFree (runSum runLogQuiet runFilesFs) app2
running filesMkdir
running filesLs
running filesRmdir

Ou encore runLogVerbose et runFilesFs :

*Main> foldFree (runSum runLogVerbose runFilesFs) app2
running filesMkdir
running filesLs
running filesRmdir
[Log] ["myfiles-sum.hs","myfiles-mtl.hs"...

Ainsi, au prix d’un peu de “code plomberie”, on peut combiner plusieurs free monads et réutiliser leurs interpréteurs. Ici, on a utilisé le type Sum mais on peut également utiliser le transformateur de free monads FreeT (voir l’exemple dans le dépôt de code)

On notera cependant que les interpréteurs sont ici indépendants. Par exemple, runFilesFs affiche des messages via putStrLn, or il pourrait être intéressant d’utiliser logPut plutôt.

Exemple avec Polysemy

Polysemy est une bibliothèque, basée sur les free monads, qui permet d’implémenter facilement des EDSL, des gestionnaires d’effets…

Modèle

Polysemy utilise quelques extensions de langages (GADT, TemplateHaskell…) pour simplifier son utilisation. Par exemple pour définir notre EDSL de gestion de fichiers, on peut écrire le type suivant :

data Files m a where
  FilesLs :: Files m [FilePath]
  FilesMkdir :: FilePath -> Files m ()
  FilesRmdir :: FilePath -> Files m ()

Puis générer automatiquement les fonctions primitives (filesFs, filesMkdir et filesRmdir) avec :

makeSem ''Files

De même, pour implémenter la free monad de log :

data Log m a where
  LogPut :: String -> Log m ()

makeSem ''Log

Applications

On peut alors écrire des applications en utilisant la monade Sem (pour “semantic”) et en lui indiquant les free monads nécessaires. Par exemple pour l’application app1, on a besoin uniquement de Log :

app1 :: Member Log r => Sem r ()
app1 = do
  logPut "hello"
  logPut "world"

Pour app2, on a besoin de Log et de Files. On peut aussi intégrer IO pour faire des affichages directs, en plus des logs :

app2 :: Members '[Log, Files, Embed IO] r => Sem r ()
app2 = do
  filesMkdir "output1"
  files <- filesLs
  filesRmdir "output1"
  logPut $ show files
  embed $ print files

Interpréteurs

Pour implémenter un interpréteur, on écrit comment on gère la free monad considérée. Par exemple pour gérer Log, on doit écrire comment gérer la valeur LogPut :

runLogQuiet :: Sem (Log ': r) a -> Sem r a
runLogQuiet = interpret \case
  LogPut _str -> return ()

L’interpréteur runLogQuiet n’affiche pas les messages de log et se contente de retourner (). Pour runLogVerbose, on veut afficher les messages, via putStrLn; on doit donc indiquer une dépendance à la monade IO :

runLogVerbose :: Member (Embed IO) r => Sem (Log ': r) a -> Sem r a
runLogVerbose = interpret \case
  LogPut str -> embed (putStrLn ("[Log] " ++ str))

De même pour runFilesFs, on a besoin de la monade IO, pour appeler les fonctions du module System.Directory. De plus, au lieu d’afficher directement des messages d’information (via putStrLn), on peut maintenant facilement utiliser la free monad Log : il suffit de l’indiquer dans les dépendances puis d’utiliser la fonction logPut :

runFilesFs :: Members '[Log, Embed IO] r => Sem (Files ': r) a -> Sem r a
runFilesFs = interpret \case
  FilesLs -> do
    logPut "running filesLs"
    embed $ listDirectory "."
  FilesMkdir fp -> do
    logPut "running filesMkdir"
    embed $ createDirectory fp
  FilesRmdir fp -> do
    logPut "running filesRmdir"
    embed $ removeDirectory fp

Exécution

On peut enfin exécuter les applications, en spécifiant les interpréteurs désirés. Par exemple, pour app1 avec l’interpréteur runLogVerbose :

*Main> runM . runLogVerbose $ app1
[Log] hello
[Log] world

Pour app2, on doit spécifier un interpréteur de Log et un interpréteur de Files (et faire attention à ce que l’ordre des interpréteurs respecte les dépendances). Par exemple, runLogQuiet et runFilesFs :

*Main> runM . runLogQuiet . runFilesFs $ app2
["myfiles-sum.hs","myfiles-mtl.hs"...

Ou encore runLogVerbose et runFilesFs :

*Main> runM . runLogVerbose . runFilesFs $ app2
[Log] running filesMkdir
[Log] running filesLs
[Log] running filesRmdir
[Log] ["myfiles-sum.hs","myfiles-mtl.hs"...
["myfiles-sum.hs","myfiles-mtl.hs"...

Exemple en style Tagless Final

Comme dans le post précédent, on peut comparer les implémentations à base de free monads avec une implémentation en style Tagless Final.

Modèle

On implémente nos fonctionnalités de log et de système de fichiers avec des classes de types (MonadLog et MonadFiles), qui dérivent de la classe Monad :

class Monad m => MonadLog m where
  logPut :: String -> m ()

class Monad m => MonadFiles m where
  filesLs :: m [FilePath]
  filesMkdir :: FilePath -> m ()
  filesRmdir :: FilePath -> m ()

Applications

On peut alors écrire des applications utilisant ces monades. Par exemple, app1 fonctionne dans une monade qui instancie MonadLog, et peut donc générer des messages de logs, avec logPut :

app1 :: (MonadLog m) => m ()
app1 = do
  logPut "hello"
  logPut "world"

Pour app2, on veut générer des logs, manipuler le système de fichiers et faire des affichages via print. On doit donc fonctionner dans une monade qui instancie MonadLog, MonadFiles et IO :

app2 :: (MonadLog m,  MonadFiles m, MonadIO m) => m ()
app2 = do
  filesMkdir "output1"
  files <- filesLs
  filesRmdir "output1"
  logPut $ show files
  liftIO $ print files

Interpréteurs

Pour implémenter un interpréteur, en style Tagless Final, on définit un wrapper de types et on instancie la classe à interpréter. Par exemple, pour interpréter MonadLog de façon à ne pas afficher les messages de log, on peut écrire le type LogQuiet suivant :

newtype LogQuiet m a = LogQuiet { runLogQuiet :: m a }
  deriving (Functor, Applicative, Monad)

instance Monad m => MonadLog (LogQuiet m) where
  logPut _ = return ()

Si on veut réellement afficher les messages, via putStrLn, on doit alors indiquer la dépendance à MonadIO (la classe de type correspondant à IO) :

newtype LogVerbose m a = LogVerbose { runLogVerbose :: m a }
  deriving (Functor, Applicative, Monad, MonadIO)

instance MonadIO m => MonadLog (LogVerbose m) where
  logPut str = liftIO (putStrLn ("[Log] " ++ str))

De même, pour interpréter MonadFiles, on a besoin de MonadIO (pour les opérations sur le système de fichiers) et de MonadLog (pour générer les messages d’information via logPut) :

newtype FilesFs m a = FilesFs { runFilesFs :: m a }
  deriving (Functor, Applicative, Monad, MonadLog, MonadIO)

instance (MonadLog m, MonadIO m) => MonadFiles (FilesFs m) where
  filesLs = do
    logPut "running filesLs"
    liftIO $ listDirectory "."
  filesMkdir fp =  do
    logPut "running filesMkdir"
    liftIO $ createDirectory fp
  filesRmdir fp =  do
    logPut "running filesRmdir"
    liftIO $ removeDirectory fp

Exécution

Pour exécuter les interpréteurs, il suffit d’appeler les fonctions correspondantes. Par exemple, pour interpréter app1 en affichant les messages de log :

*Main> runLogVerbose app1
[Log] hello
[Log] world

Pour exécuter app2 en réalisant les opérations sur le système de fichier et sans afficher les messages de log :

*Main> runLogQuiet $ runFilesFs app2
["myfiles-sum.hs","myfiles-mtl.hs"...

Et idem mais en affichant les messages de log :

*Main> runLogVerbose $ runFilesFs app2
[Log] running filesMkdir
[Log] running filesLs
[Log] running filesRmdir
[Log] ["myfiles-sum.hs","myfiles-mtl.hs"...
["myfiles-sum.hs","myfiles-mtl.hs"...

Conclusion

On peut combiner plusieurs free monads avec un type somme (comme Sum) ou avec un transformateur de free monads (comme FreeT). Cependant, il est généralement plus pratique d’utiliser un système d’effet comme Polysemy ou le style Tagless Final.

Quelques liens intéressants :

• Free monad considered harmful
• Modern Functional Programming: Part 2
• Combining Free types