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 :