Fix compiler error on import cycles (#3171)

- Fixes #3161 

The strongly connected components given in [this
function](https://hackage.haskell.org/package/containers-0.7/docs/Data-Graph.html#v:stronglyConnComp)
are not guaranteed to give a cycle in the order they are given. I've
fixed that

app/Commands/Dev/Anoma.hs

@@ -10,4 +10,4 @@ import Commands.Dev.Anoma.Options
 
 runCommand :: (Members AppEffects r) => AnomaCommand -> Sem r ()
 runCommand = \case
-  Node opts -> Node.runCommand opts
+  AnomaCommandNode opts -> Node.runCommand opts

app/Commands/Dev/Anoma/Options.hs

@@ -4,7 +4,7 @@ import Commands.Dev.Anoma.Node.Options
 import CommonOptions
 
 newtype AnomaCommand
-  = Node NodeOptions
+  = AnomaCommandNode NodeOptions
   deriving stock (Data)
 
 parseAnomaCommand :: Parser AnomaCommand
@@ -20,5 +20,5 @@ parseAnomaCommand =
         runInfo :: ParserInfo AnomaCommand
         runInfo =
           info
-            (Node <$> parseNodeOptions)
+            (AnomaCommandNode <$> parseNodeOptions)
             (progDesc "Run an Anoma node and client.")

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/Backend/Html/Translation/FromTyped.hs

@@ -18,7 +18,7 @@ import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Print
 import Juvix.Compiler.Pipeline.EntryPoint
 import Juvix.Extra.Assets
-import Juvix.Prelude
+import Juvix.Prelude hiding (Tree)
 import Juvix.Prelude.Pretty
 import Text.Blaze.Html.Renderer.Utf8 qualified as Html
 import Text.Blaze.Html5 as Html hiding (map)

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

@@ -3,6 +3,7 @@
 module Juvix.Prelude.Base.Foundation
   ( module Juvix.Prelude.Base.Foundation,
     module Control.Applicative,
+    module Data.Tree,
     module Data.Graph,
     module Text.Show.Unicode,
     module Data.Map.Strict,
@@ -123,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
@@ -136,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
@@ -188,6 +191,7 @@ import Data.Text.IO.Utf8 hiding (getContents, getLine, hGetLine, hPutStr, hPutSt
 import Data.Text.IO.Utf8 qualified as Utf8
 import Data.Text.Lazy.Builder qualified as LazyText
 import Data.Traversable
+import Data.Tree hiding (levels)
 import Data.Tuple.Extra hiding (both)
 import Data.Type.Equality (type (~))
 import Data.Typeable hiding (TyCon)
@@ -832,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)

test/Scope/Negative.hs

@@ -293,5 +293,10 @@ scoperErrorTests =
       "Invalid default"
       $(mkRelDir ".")
       $(mkRelFile "InvalidDefault.juvix")
-      $ wantsError ErrWrongDefaultValue
+      $ wantsError ErrWrongDefaultValue,
+    negTest
+      "Import cycles (issue3161)"
+      $(mkRelDir "issue3161")
+      $(mkRelFile "Stdlib/Trait/Partial.juvix")
+      $ wantsError ErrImportCycleNew
   ]

tests/negative/issue3161/Package.juvix

@@ -0,0 +1,10 @@
+module Package;
+
+import PackageDescription.V2 open;
+
+package : Package :=
+  defaultPackage@?{
+    name := "stdlib";
+    version := mkVersion 0 0 1;
+    dependencies := []
+  };

tests/negative/issue3161/Stdlib/Data/Fixity.juvix

@@ -0,0 +1,3 @@
+module Stdlib.Data.Fixity;
+
+import Juvix.Builtin.V1.Fixity open public;

tests/negative/issue3161/Stdlib/Data/List/Base.juvix

@@ -0,0 +1,6 @@
+module Stdlib.Data.List.Base;
+
+import Juvix.Builtin.V1.List open public;
+import Stdlib.Data.Fixity open;
+import Stdlib.Trait.Ord open;
+import Stdlib.Trait.Partial open;

tests/negative/issue3161/Stdlib/Data/String/Base.juvix

@@ -0,0 +1,5 @@
+module Stdlib.Data.String.Base;
+
+import Juvix.Builtin.V1.String open public;
+import Stdlib.Data.List.Base open;
+import Stdlib.Data.Fixity open;

tests/negative/issue3161/Stdlib/Data/String/Ord.juvix

@@ -0,0 +1,4 @@
+module Stdlib.Data.String.Ord;
+
+import Stdlib.Data.Fixity open;
+import Stdlib.Data.String.Base open;

tests/negative/issue3161/Stdlib/Debug/Fail.juvix

@@ -0,0 +1,3 @@
+module Stdlib.Debug.Fail;
+
+import Stdlib.Data.String.Base open;

tests/negative/issue3161/Stdlib/Trait/Ord.juvix

@@ -0,0 +1,3 @@
+module Stdlib.Trait.Ord;
+
+import Stdlib.Data.Fixity open;

tests/negative/issue3161/Stdlib/Trait/Partial.juvix

@@ -0,0 +1,4 @@
+module Stdlib.Trait.Partial;
+
+import Stdlib.Data.String.Base open;
+import Stdlib.Debug.Fail as Debug;