置換の合成

複数の置換を合成したりしたい場面がありました。
symm.hs

module Symm(Symmetric(Symm),clean) where
import Data.List
import Data.Monoid

data Symmetric a = Symm [(a,a)] deriving (Show,Eq)

conc :: Eq a => [(a, a)] -> [(a, a)] -> [(a, a)]
conc as [] = as
conc [] bs = bs
conc (a@(f,t):as) bs = a':conc as restBs
        where
             a' = conc' a $ find (\(x,y) -> t == x) bs
             restBs = filter (\(x,y) -> t /= x) bs
             conc' (f, t) (Just (x, y)) = (f, y) 
             conc' (f, t) Nothing = (f, t)

instance Eq a => Monoid (Symmetric a) where
        mempty = Symm []
        (Symm as) `mappend` (Symm bs) = Symm (conc as bs)

clean :: Eq a => Symmetric a -> Symmetric a
clean (Symm as) = Symm $ filter (\(f,t) -> f /= t) as

main.hs

module Main where
import Symm 
import Data.Monoid

a = Symm [(1,3),(2,4)]
b = Symm [(3,5),(4,6),(5,7)]

main :: IO ()
main = print $ clean $ a `mappend` b

実行結果

Symm [(1,5),(2,6),(5,7)]