Find cycle and connected components with disjoint set with haskell

ds_cycle_cc.hs

{-# LANGUAGE ScopedTypeVariables #-}
import Control.Monad
import Data.Maybe
import qualified Data.List as L
import qualified Data.Map as M

data Uedge a = Ue (a,a) deriving Show

instance Eq a => Eq (Uedge a) where
  (==) (Ue (a,b)) (Ue (a1,b1)) = (a == a1 &&  b==b1 ) || (a==b1 && b==a1)

data Graph a = G [Uedge a] deriving Show

--g = G [Ue ('a','b'), Ue ('b','c') , Ue ('x','a'),Ue ('b','z'),Ue ('z','c'),Ue ('a','w'),Ue ('c','w')]
g = G [Ue ('a','b'),Ue ('b','c'),Ue ('c','d'),Ue ('d','a'),Ue ('a','x'),Ue ('j','k')]

vertices :: Eq a => Graph a -> [a]
vertices (G l) = L.nub.join $ [ [a,b] | (Ue (a,b)) <- l]

--MakeSet (x)
--Union (r,s)
--Find (x)

-- https://en.wikipedia.org/wiki/Disjoint-set_data_structure

class DisjS c where
  empty :: Ord a => c a
  makeset :: Ord a => a -> c a -> c a
  find :: Ord a => a -> c a -> Maybe (a, Int)
  union :: Ord a => a -> a -> c a -> Maybe (Bool, (c a))

data DS a = DS (M.Map a (a,Int)) deriving Show

instance DisjS DS where
  empty = DS M.empty
  makeset v (DS m) = DS $ M.insert v (v,1) m
  find curr d@(DS m) = do p@(v,i) <- M.lookup curr m
                          if v == curr then Just p else find v d

  union a b d@(DS m) = do
                         ap@(ar, ac) <- find a d
                         bp@(br, bc) <- find b d
                         if ar == br then Just (False,d) else Just $ (True, nd ap bp) where
                         nd ap bp = DS $ nm where nm = M.insert rmin (rmax, minn) nm'
                                                  nm' = M.insert rmax (rmax, maxn+minn) m
                                                  (rmax, maxn) = max ap bp
                                                  (rmin, minn) = min ap bp

fromList xs = foldr makeset empty xs
dunion a b d = snd.fromJust $ union a b d


has_cycle :: forall a.Ord a => Graph a -> Bool
has_cycle g@(G l) = go l d
                     where
                       d = fromList $ vertices g :: DS a
                       go :: [Uedge a] -> DS a -> Bool
                       go [] _ = False
                       go ((Ue (a,b)):es) d | no_loop = go es d'
                                            | otherwise = True
                                              where
                                                (no_loop,d') = fromJust $ union a b d


ccomps :: forall a.Ord a => Graph a -> M.Map a [a]
ccomps g@(G l) = M.fromListWith (++) [(fst.fromJust $ find v ds,[v]) | v <- vertices g ]
                   where
                     ds :: DS a
                     ds = foldl f d l
                     f d (Ue (a,b)) = dunion a b d
                     d = fromList $ vertices g