Multi component issues in GHC 9.2 (#2687)

* Delete useAnnotatedParsedSource (not used anywhere)

* Multi component test suite: test packages

* Multi component test suite: replace delays with waits

* Multi component: test with 3 components

* Helpers for reference/ready message parsing

* Multi component test: wait for reference ready

* mark test as known broken in 9.2

Author: pepeiborra

ghcide/src/Development/IDE/GHC/ExactPrint.hs

@@ -23,7 +23,6 @@ module Development.IDE.GHC.ExactPrint
       transformM,
       ExactPrint(..),
 #if !MIN_VERSION_ghc(9,2,0)
-      useAnnotatedSource,
       Anns,
       Annotate,
       setPrecedingLinesT,
@@ -122,16 +121,6 @@ annotateParsedSource :: ParsedModule -> Annotated ParsedSource
 annotateParsedSource = fixAnns
 #endif
 
-#if !MIN_VERSION_ghc(9,2,0)
-useAnnotatedSource ::
-  String ->
-  IdeState ->
-  NormalizedFilePath ->
-  IO (Maybe (Annotated ParsedSource))
-useAnnotatedSource herald state nfp =
-    runAction herald state (use GetAnnotatedParsedSource nfp)
-#endif
-
 ------------------------------------------------------------------------------
 
 {- | A transformation for grafting source trees together. Use the semigroup

ghcide/test/data/multi/a/A.hs

@@ -1,3 +1,3 @@
 module A(foo) where
-
+import Control.Concurrent.Async
 foo = ()

ghcide/test/data/multi/a/a.cabal

@@ -4,6 +4,6 @@ build-type: Simple
 cabal-version: >= 1.2
 
 library
-  build-depends: base
+  build-depends: base, async
   exposed-modules: A
   hs-source-dirs: .

ghcide/test/data/multi/c/C.hs

@@ -0,0 +1,3 @@
+module C(module C) where
+import A
+cux = foo

ghcide/test/data/multi/c/c.cabal

@@ -0,0 +1,9 @@
+name: c
+version: 1.0.0
+build-type: Simple
+cabal-version: >= 1.2
+
+library
+  build-depends: base, a
+  exposed-modules: C
+  hs-source-dirs: .

ghcide/test/data/multi/cabal.project

@@ -1 +1 @@
-packages: a b
+packages: a b c

ghcide/test/data/multi/hie.yaml

@@ -4,3 +4,5 @@ cradle:
       component: "lib:a"
     - path: "./b"
       component: "lib:b"
+    - path: "./c"
+      component: "lib:c"

ghcide/test/exe/Main.hs

@@ -58,7 +58,9 @@ import           Development.IDE.Test                     (Cursor,
                                                            standardizeQuotes,
                                                            waitForAction,
                                                            waitForGC,
-                                                           waitForTypecheck)
+                                                           waitForTypecheck,
+                                                           isReferenceReady,
+                                                           referenceReady)
 import           Development.IDE.Test.Runfiles
 import qualified Development.IDE.Types.Diagnostics        as Diagnostics
 import           Development.IDE.Types.Location
@@ -5373,7 +5375,7 @@ cradleTests = testGroup "cradle"
     [testGroup "dependencies" [sessionDepsArePickedUp]
     ,testGroup "ignore-fatal" [ignoreFatalWarning]
     ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
-    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest]
+    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest]
     ,testGroup "sub-directory"   [simpleSubDirectoryTest]
     ]
 
@@ -5493,12 +5495,10 @@ simpleMultiTest :: TestTree
 simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do
     let aPath = dir </> "a/A.hs"
         bPath = dir </> "b/B.hs"
-    aSource <- liftIO $ readFileUtf8 aPath
-    adoc <- createDoc aPath "haskell" aSource
+    adoc <- openDoc aPath "haskell"
+    bdoc <- openDoc bPath "haskell"
     WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc
     liftIO $ assertBool "A should typecheck" ideResultSuccess
-    bSource <- liftIO $ readFileUtf8 bPath
-    bdoc <- createDoc bPath "haskell" bSource
     WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc
     liftIO $ assertBool "B should typecheck" ideResultSuccess
     locs <- getDefinitions bdoc (Position 2 7)
@@ -5511,15 +5511,30 @@ simpleMultiTest2 :: TestTree
 simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do
     let aPath = dir </> "a/A.hs"
         bPath = dir </> "b/B.hs"
-    bSource <- liftIO $ readFileUtf8 bPath
-    bdoc <- createDoc bPath "haskell" bSource
-    expectNoMoreDiagnostics 10
-    aSource <- liftIO $ readFileUtf8 aPath
-    (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
-    -- Need to have some delay here or the test fails
-    expectNoMoreDiagnostics 10
+    bdoc <- openDoc bPath "haskell"
+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc
+    TextDocumentIdentifier auri <- openDoc aPath "haskell"
+    skipManyTill anyMessage $ isReferenceReady aPath
     locs <- getDefinitions bdoc (Position 2 7)
-    let fooL = mkL adoc 2 0 2 3
+    let fooL = mkL auri 2 0 2 3
+    checkDefs locs (pure [fooL])
+    expectNoMoreDiagnostics 0.5
+
+-- Now with 3 components
+simpleMultiTest3 :: TestTree
+simpleMultiTest3 = knownBrokenForGhcVersions [GHC92] "#2693" $
+  testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do
+    let aPath = dir </> "a/A.hs"
+        bPath = dir </> "b/B.hs"
+        cPath = dir </> "c/C.hs"
+    bdoc <- openDoc bPath "haskell"
+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc
+    TextDocumentIdentifier auri <- openDoc aPath "haskell"
+    skipManyTill anyMessage $ isReferenceReady aPath
+    cdoc <- openDoc cPath "haskell"
+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
+    locs <- getDefinitions cdoc (Position 2 7)
+    let fooL = mkL auri 2 0 2 3
     checkDefs locs (pure [fooL])
     expectNoMoreDiagnostics 0.5
 
@@ -5531,11 +5546,7 @@ simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi
     adoc <- liftIO $ runInDir dir $ do
       aSource <- liftIO $ readFileUtf8 aPath
       adoc <- createDoc aPath "haskell" aSource
-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
-        FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
-          A.Success fp' <- pure $ fromJSON fp
-          if equalFilePath fp' aPath then pure () else Nothing
-        _ -> Nothing
+      skipManyTill anyMessage $ isReferenceReady aPath
       closeDoc adoc
       pure adoc
     bSource <- liftIO $ readFileUtf8 bPath
@@ -5566,18 +5577,15 @@ bootTests = testGroup "boot"
             -- `ghcide/reference/ready` notification.
             -- Once we receive one of the above, we wait for the other that we
             -- haven't received yet.
-            -- If we don't wait for the `ready` notification it is possible 
-            -- that the `getDefinitions` request/response in the outer ghcide 
+            -- If we don't wait for the `ready` notification it is possible
+            -- that the `getDefinitions` request/response in the outer ghcide
             -- session will find no definitions.
             let hoverParams = HoverParams cDoc (Position 4 3) Nothing
             hoverRequestId <- sendRequest STextDocumentHover hoverParams
-            let parseReadyMessage = satisfy $ \case
-                  FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = params})
-                    | A.Success fp <- fromJSON params -> equalFilePath fp cPath
-                  _ -> False
+            let parseReadyMessage = isReferenceReady cPath
             let parseHoverResponse = responseForId STextDocumentHover hoverRequestId
             hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage))
-            _ <- skipManyTill anyMessage $ 
+            _ <- skipManyTill anyMessage $
               case hoverResponseOrReadyMessage of
                 Left _ -> void parseReadyMessage
                 Right _ -> void parseHoverResponse
@@ -5990,11 +5998,7 @@ referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "reference
     loop :: [FilePath] -> Session ()
     loop [] = pure ()
     loop docs = do
-      doc <- skipManyTill anyMessage $ satisfyMaybe $ \case
-          FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do
-            A.Success fp' <- pure $ fromJSON fp
-            find (fp' ==) docs
-          _ -> Nothing
+      doc <- skipManyTill anyMessage $ referenceReady (`elem` docs)
       loop (delete doc docs)
   loop docs
   f dir

ghcide/test/src/Development/IDE/Test.hs

@@ -29,7 +29,13 @@ module Development.IDE.Test
   , getStoredKeys
   , waitForCustomMessage
   , waitForGC
-  ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount,configureCheckProject) where
+  , getBuildKeysBuilt
+  , getBuildKeysVisited
+  , getBuildKeysChanged
+  , getBuildEdgesCount
+  , configureCheckProject
+  , isReferenceReady
+  , referenceReady) where
 
 import           Control.Applicative.Combinators
 import           Control.Lens                    hiding (List)
@@ -58,6 +64,7 @@ import           Language.LSP.Types.Lens         as Lsp
 import           System.Directory                (canonicalizePath)
 import           System.Time.Extra
 import           Test.Tasty.HUnit
+import System.FilePath (equalFilePath)
 
 requireDiagnosticM
     :: (Foldable f, Show (f Diagnostic), HasCallStack)
@@ -254,3 +261,16 @@ configureCheckProject overrideCheckProject =
     sendNotification SWorkspaceDidChangeConfiguration
         (DidChangeConfigurationParams $ toJSON
             def{checkProject = overrideCheckProject})
+
+-- | Pattern match a message from ghcide indicating that a file has been indexed
+isReferenceReady :: FilePath -> Session ()
+isReferenceReady p = void $ referenceReady (equalFilePath p)
+
+referenceReady :: (FilePath -> Bool) -> Session FilePath
+referenceReady pred = satisfyMaybe $ \case
+  FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params})
+    | A.Success fp <- A.fromJSON _params
+    , pred fp
+    -> Just fp
+  _ -> Nothing
+