fix import cycle error

package.yaml

@@ -47,10 +47,11 @@ extra-source-files:
   - config/configure.sh
 
 dependencies:
-  - aeson-better-errors == 0.9.*
   - aeson == 2.2.*
+  - aeson-better-errors == 0.9.*
   - aeson-pretty == 0.8.*
   - ansi-terminal == 1.1.*
+  - array == 0.5.*
   - base == 4.19.*
   - base16-bytestring == 1.0.*
   - base64-bytestring == 1.2.*

src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs

@@ -119,8 +119,7 @@ instance ToGenericError InfixErrorP where
               <> "Perhaps you forgot parentheses around a pattern?"
 
 newtype ImportCycleNew = ImportCycleNew
-  { -- | If we have [a, b, c] it means that a import b imports c imports a.
-    _importCycleImportsNew :: NonEmpty ImportScan
+  { _importCycleImportsNew :: GraphCycle ImportScan
   }
   deriving stock (Show)
 
@@ -136,7 +135,8 @@ instance ToGenericError ImportCycleNew where
             }
         where
           opts' = fromGenericOptions opts
-          h = head _importCycleImportsNew
+          cycl = _importCycleImportsNew ^. graphCycleVertices
+          h = head cycl
           i = getLoc h
           msg =
             "There is an import cycle:"
@@ -147,7 +147,7 @@ instance ToGenericError ImportCycleNew where
                      . map pp
                      . toList
                      . tie
-                     $ _importCycleImportsNew
+                     $ cycl
                  )
 
           pp :: ImportScan -> Doc Ann

src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree.hs

@@ -1,6 +1,8 @@
 module Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree where
 
 import Data.HashMap.Strict qualified as HashMap
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Text qualified as Text
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
 import Juvix.Compiler.Concrete.Translation.ImportScanner
 import Juvix.Compiler.Pipeline.Loader.PathResolver.Base
@@ -114,38 +116,42 @@ withImportTree entryModule x = do
 
 checkImportTreeCycles :: forall r. (Members '[Error ScoperError] r) => ImportTree -> Sem r ()
 checkImportTreeCycles tree = do
-  let sccs =
-        stronglyConnComp
-          [ (node, node, toList v) | (node, v) <- HashMap.toList (tree ^. importTree)
-          ]
-  whenJust (firstJust getCycle sccs) $ \(cyc :: NonEmpty ImportNode) ->
+  let graph :: GraphInfo ImportNode ImportNode =
+        mkGraphInfo [(node, node, toList v) | (node, v) <- HashMap.toList (tree ^. importTree)]
+  whenJust (graphCycle graph) $ \(cyc :: GraphCycle ImportNode) ->
     throw
       . ErrImportCycleNew
       . ImportCycleNew
-      $ getEdges cyc
+      . getEdges
+      $ cyc
   where
-    getEdges :: NonEmpty ImportNode -> NonEmpty ImportScan
-    getEdges = fmap (uncurry getEdge) . zipWithNextLoop
-
-    getEdge :: ImportNode -> ImportNode -> ImportScan
-    getEdge fromN toN = fromMaybe unexpected $ do
-      edges <- tree ^. importTreeEdges . at fromN
-      let rel :: Path Rel File = removeExtensions (toN ^. importNodeFile)
-          cond :: ImportScan -> Bool
-          cond = (== rel) . importScanToRelPath
-      find cond edges
+    getEdges :: GraphCycle ImportNode -> GraphCycle ImportScan
+    getEdges cycl =
+      over
+        graphCycleVertices
+        ( fmap (uncurry getEdge)
+            . zipWithNextLoop
+        )
+        cycl
       where
-        unexpected =
-          error $
-            "Impossible: Could not find edge between\n"
-              <> prettyText fromN
-              <> "\nand\n"
-              <> prettyText toN
-              <> "\n"
-              <> "Available Edges:\n"
-              <> prettyText (toList (tree ^. importTreeEdges . at fromN . _Just))
-
-    getCycle :: SCC ImportNode -> Maybe (NonEmpty ImportNode)
-    getCycle = \case
-      AcyclicSCC {} -> Nothing
-      CyclicSCC l -> Just (nonEmpty' l)
+        getEdge :: ImportNode -> ImportNode -> ImportScan
+        getEdge fromN toN = fromMaybe unexpected $ do
+          edges <- tree ^. importTreeEdges . at fromN
+          let rel :: Path Rel File = removeExtensions (toN ^. importNodeFile)
+              cond :: ImportScan -> Bool
+              cond = (== rel) . importScanToRelPath
+          find cond edges
+          where
+            unexpected =
+              impossibleError $
+                "Could not find edge between\n"
+                  <> prettyText fromN
+                  <> "\nand\n"
+                  <> prettyText toN
+                  <> "\n"
+                  <> "Available Edges from "
+                  <> prettyText fromN
+                  <> ":\n"
+                  <> prettyText (toList (tree ^. importTreeEdges . at fromN . _Just))
+                  <> "\n\nCycle found:\n"
+                  <> Text.unlines (prettyText <$> toList (cycl ^. graphCycleVertices))

src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree/Base.hs

@@ -79,8 +79,6 @@ runImportTreeBuilder = reinterpret (runState emptyImportTree) $ \case
     modify (over fimportTree (insertHelper fromNode toNode))
     modify (over fimportTreeReverse (insertHelper toNode fromNode))
     modify (over fimportTreeEdges (insertHelper fromNode importScan))
-    where
-
   where
     insertHelper :: (Hashable k, Hashable v) => k -> v -> HashMap k (HashSet v) -> HashMap k (HashSet v)
     insertHelper k v = over (at k) (Just . maybe (HashSet.singleton v) (HashSet.insert v))

src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree/ImportNode.hs

@@ -10,7 +10,7 @@ data ImportNode = ImportNode
   deriving stock (Eq, Ord, Generic, Show)
 
 instance Pretty ImportNode where
-  pretty ImportNode {..} = pretty _importNodePackageRoot <+> ":" <+> show _importNodeFile
+  pretty ImportNode {..} = pretty _importNodePackageRoot <+> ":" <+> pretty _importNodeFile
 
 instance Hashable ImportNode
 

src/Juvix/Prelude/Base/Foundation.hs

@@ -124,6 +124,7 @@ import Control.Monad.Extra qualified as Monad
 import Control.Monad.Fix
 import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Zip
+import Data.Array qualified as Array
 import Data.Bifunctor hiding (first, second)
 import Data.Bitraversable
 import Data.Bool
@@ -137,7 +138,8 @@ import Data.Foldable hiding (foldr1, minimum, minimumBy)
 import Data.Function
 import Data.Functor
 import Data.Functor.Identity
-import Data.Graph (Graph, SCC (..), Vertex, stronglyConnComp)
+import Data.Graph (Graph, SCC (..), Vertex, scc, stronglyConnComp)
+import Data.Graph qualified as Graph
 import Data.HashMap.Lazy qualified as LazyHashMap
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
@@ -834,3 +836,55 @@ unicodeSubscript = pack . map toSubscript . show
       '8' -> '₈'
       '9' -> '₉'
       _ -> impossible
+
+-- | A list of vertices [v1, .., vn], s.t. ∀i, ⟨vi, v(i+1 `mod` n)⟩ ∈ Edges
+newtype GraphCycle a = GraphCycle
+  { _graphCycleVertices :: NonEmpty a
+  }
+  deriving stock (Show)
+
+makeLenses ''GraphCycle
+
+data GraphInfo node key = GraphInfo
+  { _graphInfoGraph :: Graph,
+    _graphInfoNodeFromVertex :: Vertex -> (node, key, [key]),
+    _graphInfoKeyToVertex :: key -> Maybe Vertex
+  }
+
+makeLenses ''GraphInfo
+
+mkGraphInfo :: (Ord key) => [(node, key, [key])] -> GraphInfo node key
+mkGraphInfo e =
+  let (_graphInfoGraph, _graphInfoNodeFromVertex, _graphInfoKeyToVertex) = Graph.graphFromEdges e
+   in GraphInfo {..}
+
+graphCycle :: forall node key. GraphInfo node key -> Maybe (GraphCycle node)
+graphCycle gi =
+  case mapM_ findCycle sccs of
+    Right {} -> Nothing
+    Left cycl ->
+      Just
+        . over graphCycleVertices (fmap getNode)
+        . GraphCycle
+        . NonEmpty.reverse
+        $ cycl
+  where
+    sccs :: [Tree Vertex] = scc g
+    g :: Graph = gi ^. graphInfoGraph
+
+    getNode :: Vertex -> node
+    getNode v = fst3 ((gi ^. graphInfoNodeFromVertex) v)
+
+    isEdge :: Vertex -> Vertex -> Bool
+    isEdge v u = u `elem` (g Array.! v)
+
+    findCycle :: Tree Vertex -> Either (NonEmpty Vertex) ()
+    findCycle (Node root ch) = goChildren (pure root) ch
+      where
+        go :: NonEmpty Vertex -> Tree Vertex -> Either (NonEmpty Vertex) ()
+        go path (Node n ns)
+          | isEdge n root = Left (NonEmpty.cons n path)
+          | otherwise = goChildren (NonEmpty.cons n path) ns
+
+        goChildren :: NonEmpty Vertex -> [Tree Vertex] -> Either (NonEmpty Vertex) ()
+        goChildren path = mapM_ (go path)