Suffix trees are united monoids

SuffixTree.hs

{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}

import qualified Data.Map as M
import Data.List
import Data.String
import Data.Functor

newtype SuffixTree a = ST (M.Map a (SuffixTree a)) deriving (Eq, Ord)

instance Ord a => Semigroup (SuffixTree a) where
  ST l <> ST r = ST $ M.unionWith (<>) l r

instance Ord a => Monoid (SuffixTree a) where
  mempty = ST mempty

instance Ord a => Semilattice (SuffixTree a)

instance Ord a => United (SuffixTree a) where
  ST l `connect` r = ST (l <&> (`connect` r)) <> r

toListOfWords :: SuffixTree a -> [[a]]
toListOfWords (ST m) = (M.toList m >>= \(a, n) -> map (a:) (toListOfWords n)) ++ return []

instance Show (SuffixTree String) where
  show = intercalate " + " . map (\as -> if null as then "e" else concat as) . toListOfWords 

instance (Ord a, IsString a) => IsString (SuffixTree a) where
  fromString a = ST $ M.singleton (fromString a) mempty

-- Laws:
-- * Commutativity: a <> b = b <> a
-- * Idempotence:   a <> a = a
class Monoid m => Semilattice m

empty :: Semilattice m => m
empty = mempty

overlay :: Semilattice m => m -> m -> m
overlay = mappend

overlays :: Semilattice m => [m] -> m
overlays = foldr overlay empty

infixr 6 <+>
(<+>) :: Semilattice m => m -> m -> m
(<+>) = overlay

-- The natural partial order on the semilattice
isContainedIn :: (Eq m, Semilattice m) => m -> m -> Bool
isContainedIn x y = x <+> y == y

-- Laws:
-- * Associativity:  x <.> (y <.> z) == (x <.> y) <.> z
-- * Distributivity: x <.> (y <+> z) == x <.> y <+> x <.> z 
--                   (x <+> y) <.> z == x <.> z <+> y <.> z
-- * Containment:            x <.> y == x <.> y <+> x
class Semilattice m => United m where
    connect :: m -> m -> m

infixr 7 <.>
(<.>) :: United m => m -> m -> m
(<.>) = connect

connects :: United m => [m] -> m
connects = foldr connect empty

-- We are using OverloadedStrings for creating vertices
example :: (United m, IsString m) => m
example = overlays [ "p" <.> "q" <.> "r" <.> "s"
                   , ("r" <+> "s") <.> "t"
                   , "u"
                   , "v" <.> "x"
                   , "w" <.> ("x" <+> "y" <+> "z")
                   , "x" <.> "y" <.> "z" ]

-- Filled-in triangle
rstFace :: (United m, IsString m) => m
rstFace = "r" <.> "s" <.> "t"

-- Hollow triangle
rstSkeleton :: (United m, IsString m) => m
rstSkeleton = "r" <.> "s" <+> "r" <.> "t" <+> "s" <.> "t"