Le problème

En Haskell, on dit qu'un type est un monoïde s'il est une instance de la classe Monoid, définissant deux fonctions :

class Monoid a where
    mempty :: a
    mappend :: a -> a -> a

De plus, l'opération mappend doit être associative, et mempty doit être son élément neutre :

mempty `mappend` a == a
a `mappend` mempty == a
a `mappend` (b `mappend` c) == (a `mappend` b) `mappend` c

Par exemple, les listes forment un monoïde dont l'élément neutre est la liste vide [], et l'opération est la concaténation des listes ++. L'associativité des monoïdes permet entre autres de paralléliser facilement les opérations (exemple ici). Pour en savoir plus sur les monoïdes en Haskell, vous pouvez par exemple lire ceci.

Pour d'autres types, ça se complique : les entiers forment un monoïde avec 0 et l'addition, mais aussi avec 1 et la multiplication. Pour cela, on utilise en général newtype pour définir des synonymes ayant l'opération qui nous intéresse. Enfin, la fonction foldMap, exportée par le module Data.Foldable est plutôt utile : elle permet de réduire une liste (ou une autre structure de données) en utilisant l'opération de monoïde.

-- Sum et Product, pour avoir deux monoïdes avec les entiers
newtype Sum a = Sum { getSum :: a } deriving Show
newtype Product a = Product { getProduct :: a } deriving Show

instance (Num a) => Monoid (Sum a) where
    mempty = Sum 0
    Sum a `mappend` Sum b = Sum $ a + b

instance (Num a) => Monoid (Product a) where
    mempty = Product  1
    Product a `mappend` Product b = Product $ a * b

-- Définition de foldMap restreinte aux listes
foldMap :: (Monoid m) => (a -> m) -> [a] -> m
foldMap f [] = mempty
foldMap f (x:xs) = f x `mappend` foldMap f xs

-- factorielle et somme d'une liste
sum = getSum . foldMap Sum
fac n = getProduct $ foldMap Product [1..n]

Mais l'astuce du newtype ne règle pas tous les problèmes : on peut vouloir paramétrer le monoïde par une valeur déterminée dynamiquement. Par exemple, on pourrait vouloir prendre les k éléments les plus petits d'une liste, ou bien compter les mots de moins de k lettres comme dans le problème du robot anti-kikoolol. Mais le monoïde utilisé est déterminé statiquement en fonction du type, donc ce problème ne parait pas évident à résoudre.

La solution

Pour régler ce problème, l'idée qui nous vient est d'embarquer dans les donnés qu'on va manipuler la définition du monoïde que l'on souhaite utiliser. Ce serait assez facile pour un semigroupe (un monoïde sans l'élément neutre) :

class Semigroup a where
    sappend :: a -> a -> a

data Semi a = Semi { op :: a -> a -> a, unSemi :: a }

instance Semigroup (Semi a) where
    u `sappend` v = Semi (op u) (op u (unSemi u) (unSemi v))

semiFoldMap :: (Semigroup s) => (a -> s) -> [a] -> s
semiFoldMap f [x] = f x
semiFoldMap f (x:xs) = f x `sappend` semiFoldMap f xs
semiFoldMap f [] = error "Liste vide"

-- Cette version ne marche que pour n ≥ 1
fac' n = unSemi $ semiFoldMap semi [1..n]
    where semi = Semi (+)

Cependant, cela marche moins bien avec Monoid, puique que pour mempty, on n'a pas de valeur d'où extraire la bonne valeur. Mais il est possible de tricher : l'élément neutre a des règles intéressantes, qui fait qu'on peut simplement l'ignorer quand il ne nous arrange pas. On va donc, au lieu de manipuler des valeurs de type a, manipuler des valeurs d'un type proche de Maybe a. Cela vient du fait que l'on peut définir l'instance suivante :

-- On n'utilise pas Maybe, car une instance est déjà définie
data FromSemi s = Value s | Zero deriving Show

instance (Semigroup s) => Monoid (FromSemi s) where
    mempty = Zero
    Zero `mappend` a = a
    a `mappend` Zero = a
    (Value a) `mappend` (Value b) = Value $ a `sappend` b

-- On crée les fonctions pour packer et unpacker un monoïde
monoid :: a -> (a -> a -> a) -> (a -> FromSemi (Semi a), FromSemi (Semi a) -> a)
monoid z op = (pack, unpack)
    where pack a = Value (Semi op a)
          unpack Zero = z
          unpack (Value u) = unSemi u

fac n = unm $ foldMap m [1..n]
    where (m, unm) = monoid 1 (*)

On a donc réussi à construire des instances de Monoid dynamiquement (à un emballage/déballage près). Il reste cependant un problème un gênant : on peut mélanger des monoïdes ayant des opérations différentes et faire des truc faux sans s'en rendre compte. En effet, le type ne différencie plus l'opération utilisée. Pour régler ce problème, on va utiliser des types fantomes : on va annoter les valeurs de type Semi et Mono avec un type représentant l'opération qui va être utilisée. Mais il reste à créer un type qui va avec chaque opération. Pour cela, on utilise les types existentiels : la fonction monoid va renvoyer des valeurs telles qu'il existe un type k tel que les valeur soient annotées par k. L'avantage est que ce type est inconnu, donc différent de tous les autres : on ne peut pas mélanger deux monoïdes. Pour cela, en haskell, on met un forall t. devant le constructeur.

-- Ajoutez la ligne suivante au début du fichier :
{-# LANGUAGE ExistentialQuantification #-}

data Semi k a = Semi { op :: a -> a -> a, unSemi :: a }

instance Semigroup (Semi k a) where
    u `sappend` v = Semi (op u) (op u (unSemi u) (unSemi v))

data S a = forall k. S (a -> Semi k a) (Semi k a -> a) 

semigroup :: (a -> a -> a) -> S a
semigroup u = S (\v -> Semi u v) unSemi

type Mono k a = FromSemi (Semi k a)

data M a = forall k. M (a -> Mono k a) (Mono k a -> a)

monoid :: a -> (a -> a -> a) -> M a
monoid zero op = M pack unpack
    where pack u = Value (Semi op u)
          unpack Zero = zero
          unpack (Value v) = unSemi v 
        

On peut donc coder la bonne version de factorielle, avec un monoïde généré dynamiquement. Cependant, si on essaye d'utiliser un let ou un where pour détruire la valeur de type M a et retrouver les fonctions pour rentrer et sortir les valeurs du monoïde, GHC revoie une horrible erreur :

Monoid.hs:82:8:
    My brain just exploded.
    I can't handle pattern bindings for existential or GADT data constructors.
    Instead, use a case-expression, or do-notation, to unpack the constructor.
    In the binding group for
        M m unm
    In a pattern binding: M m unm = monoid 0 (+)
    In the definition of `Main.sum':
        Main.sum = unm . foldMap m
                 where
                     M m unm = monoid 0 (+)

Je n'ai pas réussi à trouver beaucoup plus d'explications sur cette erreur, à part ce (court) message de Simon Peyton-Jones et un passage de la documentation de GHC. En tout cas, on est obligé d'utiliser la solution un peu plus moche (au moins au niveau de la lourdeur de la syntaxe) qui consiste à utiliser case ... of :

fac1 n = case semigroup (*) of S s uns -> uns $ semiFoldMap s [1..n]

fac n = case monoid 1 (*) of M m unm -> unm $ foldMap m [1..n] 

Cette solution peut s'appliquer à d'autres types de problèmes : par exemple, lorsqu'on veut avoir une instance de Ord qui dépend d'une valeur, on peut aussi embarquer la fonction de comparaison et garantir qu'on utilisera la même fonction par un type existentiel.