From 043ec9300ae402f6ca9814e14293ddcc658172f3 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Mon, 10 Nov 2025 16:51:03 +0100
Subject: [PATCH 1/2] use containers' scc algorithm

---
 src/Constrained/Graph.hs      | 29 ++++++++++++++++-------------
 test/Constrained/GraphSpec.hs | 17 ++++++-----------
 2 files changed, 22 insertions(+), 24 deletions(-)

diff --git a/src/Constrained/Graph.hs b/src/Constrained/Graph.hs
index d8a9018..232d4bd 100644
--- a/src/Constrained/Graph.hs
+++ b/src/Constrained/Graph.hs
@@ -25,7 +25,7 @@ module Constrained.Graph (
 
 import Control.Monad
 import Data.Foldable
-import Data.List (sortOn, nub)
+import Data.List (nub)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe
@@ -33,6 +33,8 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import Prettyprinter
 import Test.QuickCheck
+-- TODO: consider using more of this
+import Data.Graph qualified as G
 
 -- | A graph with unlabeled edges for keeping track of dependencies
 data Graph node = Graph
@@ -166,21 +168,22 @@ topsort gr@(Graph e _) = go [] e
               removeNode n ds = Set.difference ds noDeps <$ guard (not $ n `Set.member` noDeps)
           if not $ null noDeps
             then go (Set.toList noDeps ++ order) (Map.mapMaybeWithKey removeNode g)
-            else Left . concat . take 1 . sortOn length . filter (not . null) . map (findCycle gr) $ Map.keys e
+            else Left $ findCycle gr
 
 -- | Simple DFS cycle finding
-findCycle :: Ord node => Graph node -> node -> [node]
-findCycle g@(Graph e _) node = concat . take 1 $ filter loopy $ go mempty node
+findCycle :: Ord node => Graph node -> [node]
+findCycle g@(Graph e _) = mkCycle . concat . take 1 . filter isCyclic . map (map tr) . concatMap cycles . G.scc $ gr
   where
-    loopy [] = False
-    loopy c@(x:_) = dependsOn (last c) x g
-    go seen n
-      | n `Set.member` seen = [[]]
-      | otherwise = do
-          n' <- neighbours
-          (n :) <$> go (Set.insert n seen) n'
-      where
-        neighbours = maybe [] Set.toList $ Map.lookup n e
+    edgeList =  [ (n, n, Set.toList es) | (n, es) <- Map.toList e ]
+    (gr, tr0, _) = G.graphFromEdges edgeList
+    tr x = let (n, _, _) = tr0 x in n
+    cycles (G.Node a []) = [[a]]
+    cycles (G.Node a as) = (a:) <$> concatMap cycles as
+    isCyclic [] = False
+    isCyclic [a] = dependsOn a a g
+    isCyclic _ = True
+    -- Removes a non-dependent stem from the start of the dependencies
+    mkCycle ns = let l = last ns in dropWhile (\ n -> not $ dependsOn l n g) ns
 
 -- | Get the dependencies of a node in the graph, `mempty` if the node is not
 -- in the graph
diff --git a/test/Constrained/GraphSpec.hs b/test/Constrained/GraphSpec.hs
index 9c88a7a..b865715 100644
--- a/test/Constrained/GraphSpec.hs
+++ b/test/Constrained/GraphSpec.hs
@@ -91,25 +91,20 @@ prop_topsort_sound g =
 
 prop_topsort_complete :: Graph Node -> Property
 prop_topsort_complete g =
-  isLeft (topsort g) === any (\ n -> not . null $ findCycle g n) (nodes g)
+  isLeft (topsort g) === not (null $ findCycle g)
 
 prop_find_cycle_sound :: Property
 prop_find_cycle_sound =
   forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g ->
-    and [ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 c))
-        | n <- Set.toList $ nodes g
-        , let c = findCycle g n
-        ]
+    let c = findCycle g
+    in counterexample (show c) $ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 c))
 
 prop_find_cycle_loops :: Property
 prop_find_cycle_loops =
   forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g ->
-    conjoin
-      [ case findCycle g n of
-          [] -> property True
-          c@(x:_) -> cover 40 True "found cycle" $ counterexample (show c) $ dependsOn (last c) x g
-      | n <- Set.toList $ nodes g
-      ]
+    case findCycle g of
+      [] -> property True
+      c@(x:_) -> cover 40 True "found cycle" $ counterexample (show c) $ dependsOn (last c) x g
 
 return []
 

From a7506ea70a7132987d03330b43484115338251f0 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <MaximilianAlgehed@users.noreply.github.com>
Date: Thu, 13 Nov 2025 15:12:27 +0100
Subject: [PATCH 2/2] Update test/Constrained/GraphSpec.hs
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Co-authored-by: Joosep Jääger <joosep.jaager@gmail.com>
---
 test/Constrained/GraphSpec.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/test/Constrained/GraphSpec.hs b/test/Constrained/GraphSpec.hs
index b865715..efd236a 100644
--- a/test/Constrained/GraphSpec.hs
+++ b/test/Constrained/GraphSpec.hs
@@ -97,7 +97,7 @@ prop_find_cycle_sound :: Property
 prop_find_cycle_sound =
   forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g ->
     let c = findCycle g
-    in counterexample (show c) $ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 c))
+    in counterexample (show c) $ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 $ cycle c))
 
 prop_find_cycle_loops :: Property
 prop_find_cycle_loops =