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 ()
= liftF $ LogPut msg ()
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
= hoistFree InL
left
right :: (Functor f, Functor g) => Free g a -> Free (Sum f g) a
= hoistFree InR right
Applications
On peut maintenant utiliser chacune des free monads précédentes. Par exemple, l’application app1
suivante utilise uniquement Log
:
app1 :: Log ()
= do
app1 "hello"
logPut "world" logPut
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 ()
= do
app2 $ filesMkdir "output1"
right <- right filesLs
files $ filesRmdir "output1"
right $ logPut $ show files left
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
LogPut str next) = do
runLogVerbose (putStrLn ("[Log] " ++ str)
return next
Un interpréteur de Log
qui n’affiche pas les messages :
runLogQuiet :: LogF a -> IO a
LogPut _str next) = do
runLogQuiet (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
FilesLs next) = do
runFilesFs (putStrLn "running filesLs"
<- listDirectory "."
files return $ next files
FilesMkdir fp next) = do
runFilesFs (putStrLn "running filesMkdir"
createDirectory fpreturn next
FilesRmdir fp next) = do
runFilesFs (putStrLn "running filesRmdir"
removeDirectory fpreturn 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
InL x) = runL x
runSum runL _ (InR x) = runR x runSum _ runR (
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 filesRmdirLog] ["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 :
'Files makeSem '
De même, pour implémenter la free monad de log :
data Log m a where
LogPut :: String -> Log m ()
'Log makeSem '
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 ()
= do
app1 "hello"
logPut "world" logPut
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 ()
= do
app2 "output1"
filesMkdir <- filesLs
files "output1"
filesRmdir $ show files
logPut $ print files embed
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
= interpret \case
runLogQuiet 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
= interpret \case
runLogVerbose 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
= interpret \case
runFilesFs FilesLs -> do
"running filesLs"
logPut $ listDirectory "."
embed FilesMkdir fp -> do
"running filesMkdir"
logPut $ createDirectory fp
embed FilesRmdir fp -> do
"running filesRmdir"
logPut $ removeDirectory fp embed
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 ()
= do
app1 "hello"
logPut "world" logPut
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 ()
= do
app2 "output1"
filesMkdir <- filesLs
files "output1"
filesRmdir $ show files
logPut $ print files liftIO
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
= return () logPut _
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
= liftIO (putStrLn ("[Log] " ++ str)) logPut 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
= do
filesLs "running filesLs"
logPut $ listDirectory "."
liftIO = do
filesMkdir fp "running filesMkdir"
logPut $ createDirectory fp
liftIO = do
filesRmdir fp "running filesRmdir"
logPut $ removeDirectory fp liftIO
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 :