Fix transitiveReverseDependencies recursion

ghcide-test/data/transitive-recomp/M0.hs

@@ -0,0 +1,4 @@
+module M0 (m0val) where
+
+m0val :: Int
+m0val = 0

ghcide-test/data/transitive-recomp/M1.hs

@@ -0,0 +1,5 @@
+module M1 (m1val) where
+
+import M0
+
+m1val = m0val

ghcide-test/data/transitive-recomp/M2.hs

@@ -0,0 +1,6 @@
+module M2 (m2val) where
+
+import M1
+
+m2val :: Int
+m2val = m1val

ghcide-test/data/transitive-recomp/hie.yaml

@@ -0,0 +1 @@
+cradle: {direct: {arguments: ["-Wmissing-signatures", "M0", "M1", "M2"]}}

ghcide-test/exe/IfaceTests.hs

@@ -28,6 +28,7 @@ tests = testGroup "Interface loading tests"
     , ifaceErrorTest2
     , ifaceErrorTest3
     , ifaceTHTest
+    , ifaceTransitivePropagationTest
     ]
 
 
@@ -137,6 +138,37 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do
 
     expectNoMoreDiagnostics 2
 
+-- | Saving a file should propagate type errors to its transitive reverse
+-- dependencies, not just immediate importers. The fixture is a 3-module chain
+-- M0 <- M1 <- M2 where M2 does not import M0 directly. Flipping M0's exported
+-- type from Int to Bool must surface a diagnostic in M2.
+ifaceTransitivePropagationTest :: TestTree
+ifaceTransitivePropagationTest = testWithExtraFiles "iface-transitive-propagation" "transitive-recomp" $ \dir -> do
+    configureCheckProject False
+    let m0Path = dir </> "M0.hs"
+        m2Path = dir </> "M2.hs"
+    m0Source <- liftIO $ readFileUtf8 m0Path
+    m2Source <- liftIO $ readFileUtf8 m2Path
+    -- Open M2 first to bring the whole chain (M2 -> M1 -> M0) into the module
+    -- graph. After this we close M2 so it leaves the FOI set.
+    m2doc <- createDoc m2Path "haskell" m2Source
+    expectDiagnostics
+      [("M1.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417")])]
+    closeDoc m2doc
+    m0doc <- createDoc m0Path "haskell" m0Source
+    -- Flip M0's exported value from Int to Bool.
+    changeDoc m0doc
+      [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $
+          T.unlines ["module M0 (m0val) where", "m0val :: Bool", "m0val = True"]]
+    sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams m0doc Nothing)
+    -- m1val is type-inferred and becomes Bool, so M2 (which has
+    -- m2val :: Int = m1val) now fails. The M2 diagnostic only reaches the
+    -- client if typecheckParents walks the transitive reverse-dep set.
+    expectDiagnostics
+      [ ("M1.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417")])
+      , ("M2.hs", [(DiagnosticSeverity_Error, (5, 8), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865")])
+      ]
+
 ifaceErrorTest3 :: TestTree
 ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do
     let bPath = dir </> "B.hs"

ghcide-test/exe/UnitTests.hs

@@ -1,41 +1,54 @@
 
 module UnitTests (tests) where
 
-import           Config                            (mkIdeTestFs)
+import           Config                                       (mkIdeTestFs)
 import           Control.Concurrent
-import           Control.Monad.IO.Class            (liftIO)
+import           Control.Monad.IO.Class                       (liftIO)
+import qualified Data.HashMap.Strict                          as HMS
+import qualified Data.IntMap.Strict                           as IntMap
+import qualified Data.IntSet                                  as IntSet
 import           Data.IORef
-import           Data.IORef.Extra                  (atomicModifyIORef_)
+import           Data.IORef.Extra                             (atomicModifyIORef_)
 import           Data.List.Extra
-import           Data.String                       (IsString (fromString))
-import qualified Data.Text                         as T
-import           Development.IDE.Core.FileStore    (getModTime)
-import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
-import qualified Development.IDE.Types.Diagnostics as Diagnostics
+import           Data.String                                  (IsString (fromString))
+import qualified Data.Text                                    as T
+import           Development.IDE.Core.FileStore               (getModTime)
+import           Development.IDE.Import.DependencyInformation (DependencyInformation (..),
+                                                               FilePathId (..),
+                                                               PathIdMap (..),
+                                                               ShowableModuleEnv (..),
+                                                               transitiveReverseDependencies)
+import           Development.IDE.Import.FindImports           (ArtifactsLocation (..))
+import qualified Development.IDE.Plugin.HLS.GhcIde            as Ghcide
+import qualified Development.IDE.Types.Diagnostics            as Diagnostics
 import           Development.IDE.Types.Location
 import qualified FuzzySearch
-import           Ide.Logger                        (Recorder, WithPriority)
-import           Ide.PluginUtils                   (pluginDescToIdePlugins)
+import           GHC.Unit.Module.Env                          (emptyModuleEnv)
+import           GHC.Unit.Module.Graph                        (emptyMG)
+import           Ide.Logger                                   (Recorder,
+                                                               WithPriority)
+import           Ide.PluginUtils                              (pluginDescToIdePlugins)
 import           Ide.Types
 import           Language.LSP.Protocol.Message
-import           Language.LSP.Protocol.Types       hiding
-                                                   (SemanticTokenAbsolute (..),
-                                                    SemanticTokenRelative (..),
-                                                    SemanticTokensEdit (..),
-                                                    mkRange)
+import           Language.LSP.Protocol.Types                  hiding
+                                                              (SemanticTokenAbsolute (..),
+                                                               SemanticTokenRelative (..),
+                                                               SemanticTokensEdit (..),
+                                                               mkRange)
 import           Language.LSP.Test
 import           Network.URI
 import qualified Progress
-import           System.IO.Extra                   hiding (withTempDir)
-import           System.Mem                        (performGC)
-import           Test.Hls                          (IdeState, def,
-                                                    runSessionWithServerInTmpDir,
-                                                    waitForProgressDone)
+import           System.IO.Extra                              hiding
+                                                              (withTempDir)
+import           System.Mem                                   (performGC)
+import           Test.Hls                                     (IdeState, def,
+                                                               runSessionWithServerInTmpDir,
+                                                               waitForProgressDone)
 import           Test.Hls.FileSystem
 import           Test.Tasty
 import           Test.Tasty.ExpectedFailure
 import           Test.Tasty.HUnit
-import           Text.Printf                       (printf)
+import           Text.Printf                                  (printf)
 
 tests :: TestTree
 tests = do
@@ -97,6 +110,39 @@ tests = do
            resolution_us <- findResolution_us 1
            let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us
            assertBool msg (resolution_us <= 1000)
+     , testCase "transitiveReverseDependencies follows the chain" $ do
+         -- Chain: 0 imported by 1, 1 imported by 2, 2 imported by 3.
+         -- transitiveReverseDependencies of node 0 must contain {1, 2, 3},
+         -- not just the immediate reverse-dep {1}.
+         let path :: Int -> NormalizedFilePath
+             path i = toNormalizedFilePath' ("/M" ++ show i ++ ".hs")
+             loc :: Int -> ArtifactsLocation
+             loc i = ArtifactsLocation (path i) Nothing True Nothing
+             pathIdMap = PathIdMap
+               { idToPathMap = IntMap.fromList [(i, loc i) | i <- [0..3]]
+               , pathToIdMap = HMS.fromList   [(path i, FilePathId i) | i <- [0..3]]
+               , nextFreshId = 4
+               }
+             revDeps = IntMap.fromList
+               [ (0, IntSet.fromList [1])
+               , (1, IntSet.fromList [2])
+               , (2, IntSet.fromList [3])
+               ]
+             depInfo = DependencyInformation
+               { depErrorNodes        = IntMap.empty
+               , depModules           = IntMap.empty
+               , depModuleDeps        = IntMap.empty
+               , depReverseModuleDeps = revDeps
+               , depPathIdMap         = pathIdMap
+               , depBootMap           = IntMap.empty
+               , depModuleFiles       = ShowableModuleEnv emptyModuleEnv
+               , depModuleGraph       = emptyMG
+               , depTransDepsFingerprints            = IntMap.empty
+               , depTransReverseDepsFingerprints     = IntMap.empty
+               , depImmediateReverseDepsFingerprints = IntMap.empty
+               }
+         (sort <$> transitiveReverseDependencies (path 0) depInfo)
+           @?= Just [path 1, path 2, path 3]
      , Progress.tests
      , FuzzySearch.tests
      ]

ghcide/src/Development/IDE/Import/DependencyInformation.hs

@@ -366,11 +366,11 @@ transitiveReverseDependencies file DependencyInformation{..} = do
     return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))
   where
     go :: Int -> IntSet -> IntSet
-    go k i =
+    go k visited =
       let outwards = IntMap.findWithDefault IntSet.empty k depReverseModuleDeps
-          res = IntSet.union i outwards
-          new = IntSet.difference i outwards
-      in IntSet.foldr go res new
+          visited' = IntSet.union visited outwards
+          new = IntSet.difference outwards visited
+      in IntSet.foldr go visited' new
 
 -- | Immediate reverse dependencies of a file
 immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]

haskell-language-server.cabal

@@ -2032,6 +2032,7 @@ test-suite ghcide-tests
     , enummapset
     , extra
     , filepath
+    , ghc
     , ghcide
     , hls-plugin-api
     , lens