WIP: Run ghcide-tests in parallel

.github/workflows/flags.yml

@@ -82,7 +82,8 @@ jobs:
           cat cabal.project.local
 
       - name: Build everything with non-default flags
-        run: cabal build all
+        # --semaphore (GHC -jsem) needs GHC >= 9.8, so skip it on 9.6.
+        run: cabal build --jobs ${{ matrix.ghc != '9.6' && '--semaphore' || '' }} all
 
   flags_post_job:
     if: always()

.github/workflows/test.yml

@@ -110,7 +110,8 @@ jobs:
           os: ${{ runner.os }}
 
       - name: Build
-        run: cabal build --max-backjumps 10000 ${CABAL_ARGS} all
+        # --semaphore (GHC -jsem) needs GHC >= 9.8, so skip it on 9.6.
+        run: cabal build --max-backjumps 10000 ${CABAL_ARGS} --jobs ${{ matrix.ghc != '9.6' && '--semaphore' || '' }} all
 
       - name: Set test options
         # See https://github.com/ocharles/tasty-rerun/issues/22 for why we need
@@ -119,6 +120,13 @@ jobs:
         run: |
           cabal configure --test-options="--rerun-update --rerun-filter failures,exceptions,new" --max-backjumps 10000
 
+      - if: matrix.os == 'windows-latest'
+        name: Run tests serially on Windows
+        # Windows runners are too slow to parallelise: concurrent in-process
+        # sessions starve each other into lsp-test message timeouts. Serialise
+        # the tests only -- builds keep their numProcessors/2 capabilities.
+        run: echo "GHCIDE_TEST_TASTY_THREADS=1" >> "$GITHUB_ENV"
+
       - if: matrix.test
         name: Test hls-graph
         run: cabal test ${CABAL_ARGS} hls-graph

cabal.project

@@ -15,11 +15,6 @@ benchmarks: True
 
 write-ghc-environment-files: never
 
--- Many of our tests only work single-threaded, and the only way to
--- ensure tasty runs everything purely single-threaded is to pass
--- this at the top-level
-test-options: -j1
-
 -- Make sure dependencies are build with haddock so we get
 -- haddock shown on hover
 package *

ghcide-test/exe/CompletionTests.hs

@@ -59,7 +59,7 @@ testSessionSingleFile testName fp txt session =
 completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree
 completionTest name src pos expected = testSessionSingleFile name "A.hs" (T.unlines src) $ do
     docId <- openDoc "A.hs" "haskell"
-    _ <- waitForDiagnostics
+    _ <- waitForTypecheck docId
 
     compls <- getAndResolveCompletions docId pos
     let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]
@@ -220,8 +220,7 @@ localCompletionTests = [
         , "  { field1 :: Int"
         , "  , field2 :: Int"
         , "  }"
-        , -- Without the following, this file doesn't trigger any diagnostics, so completionTest waits forever
-          "triggerDiag :: UnknownType"
+        , "triggerDiag :: UnknownType"
         , "foo record = record.f"
         ]
         (Position 7 21)

ghcide-test/exe/Config.hs

@@ -60,7 +60,7 @@ testSessionWithPlugin fs plugin = runSessionWithTestConfig def
     { testPluginDescriptor = plugin
     , testDirLocation = Right fs
     , testConfigCaps = lspTestCaps
-    , testShiftRoot = True
+    , testCwdHandling = NoCwdShift
     }
 
 -- * A dummy plugin for testing ghcIde
@@ -78,7 +78,7 @@ runWithDummyPlugin' fs = runSessionWithTestConfig def
     { testPluginDescriptor = dummyPlugin
     , testDirLocation = Right fs
     , testConfigCaps = lspTestCaps
-    , testShiftRoot = True
+    , testCwdHandling = NoCwdShift
     }
 
 testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree

ghcide-test/exe/CradleTests.hs

@@ -35,7 +35,8 @@ import           Language.LSP.Protocol.Types     hiding
                                                   mkRange)
 import           Language.LSP.Test
 import           System.FilePath
-import           Test.Hls                        (TestConfig (..), def,
+import           Test.Hls                        (CwdHandling (..),
+                                                  TestConfig (..), def,
                                                   runSessionWithTestConfig,
                                                   waitForBuildQueue)
 import           Test.Hls.FileSystem
@@ -284,7 +285,7 @@ runWithExtraFilesMultiComponent dirName action = do
         { testPluginDescriptor = dummyPlugin
         , testDirLocation = Right vfs
         , testConfigCaps = lspTestCaps
-        , testShiftRoot = True
+        , testCwdHandling = NoCwdShift
         , testDisableKick = True
         , testLspConfig = lspConfig
         }

ghcide-test/exe/DependentFileTest.hs

@@ -14,33 +14,39 @@ import           Language.LSP.Protocol.Types    hiding
                                                  SemanticTokensEdit (..),
                                                  mkRange)
 import           Language.LSP.Test
+import           System.FilePath                ((</>))
 import           Test.Hls
 import           Test.Hls.FileSystem
 
 
 tests :: TestTree
 tests = testGroup "addDependentFile"
     [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def
-        { testShiftRoot = True
+        { testCwdHandling = NoCwdShift
         , testDirLocation = Right (mkIdeTestFs [])
         , testPluginDescriptor = dummyPlugin
         } test]
     ]
     where
       test :: FilePath -> Session ()
-      test _ = do
+      test sessionDir = do
         -- If the file contains B then no type error
         -- otherwise type error
-        let depFilePath = "dep-file.txt"
+        -- Absolute path so the splice's qRunIO/readFile and the watched-file
+        -- notification resolve identically regardless of the process CWD.
+        let depFilePath = sessionDir </> "dep-file.txt"
+        -- show gives a properly escaped Haskell string literal, so a Windows
+        -- path's backslashes survive the splice into Foo's source.
+        let depFileLit = T.pack (show depFilePath)
         liftIO $ atomicFileWriteString depFilePath "A"
         let fooContent = T.unlines
               [ "{-# LANGUAGE TemplateHaskell #-}"
               , "module Foo where"
               , "import Language.Haskell.TH.Syntax"
               , "foo :: Int"
               , "foo = 1 + $(do"
-              , "               qAddDependentFile \"" <> T.pack depFilePath <> "\""
-              , "               f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")"
+              , "               qAddDependentFile " <> depFileLit
+              , "               f <- qRunIO (readFile " <> depFileLit <> ")"
               , "               if f == \"B\" then [| 1 |] else lift f)"
               ]
         let bazContent = T.unlines ["module Baz where", "import Foo ()"]

ghcide-test/exe/FindDefinitionAndHoverTests.hs

@@ -307,7 +307,7 @@ linkToTests =
         { testPluginDescriptor = dummyPlugin
         , testDirLocation = Right (mkIdeTestFs [copyDir "hover"])
         , testConfigCaps = lspTestCaps
-        , testShiftRoot = True
+        , testCwdHandling = NoCwdShift
         , testLspConfig = lspConf
         }
     hoverCheck pos fp expects = do

ghcide-test/exe/ResolveTests.hs

@@ -24,7 +24,7 @@ import           Language.LSP.Test             hiding (resolveCompletion)
 import           Test.Hls                      (IdeState, SMethod (..), liftIO,
                                                 mkPluginTestDescriptor,
                                                 someMethodToMethodString,
-                                                waitForAllProgressDone)
+                                                waitForTypecheck)
 import qualified Test.Hls.FileSystem           as FS
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -100,7 +100,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForAllProgressDone
+      _ <- waitForTypecheck doc
       items <- getCompletions doc (Position 2 7)
       let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items
       liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems)
@@ -113,7 +113,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForAllProgressDone
+      _ <- waitForTypecheck doc
       -- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic
       -- locations and we don't have diagnostics in these tests.
       cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0))
@@ -128,7 +128,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForAllProgressDone
+      _ <- waitForTypecheck doc
       cd <- getCodeLenses doc
       let resolveCodeLenses = filter (\i -> case i ^. J.command of
             Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title)

ghcide-test/exe/RootUriTests.hs

@@ -9,7 +9,7 @@ import           System.FilePath
 -- import Test.QuickCheck.Instances ()
 import           Config
 import           Data.Default             (def)
-import           Test.Hls                 (TestConfig (..),
+import           Test.Hls                 (CwdHandling (..), TestConfig (..),
                                            runSessionWithTestConfig)
 import           Test.Hls.FileSystem      (copyDir)
 import           Test.Tasty
@@ -33,7 +33,7 @@ tests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do
             , testDirLocation = Right $ mkIdeTestFs [copyDir "rootUri"]
             , testServerRoot = Just dir1
             , testClientRoot = Just dir2
-            , testShiftRoot = True
+            , testCwdHandling = NoCwdShift
         }
 
 

ghcide-test/exe/THTests.hs

@@ -2,13 +2,16 @@
 module THTests (tests) where
 
 import           Config
+import           Control.Applicative         ((<|>))
+import           Control.Lens                ((^.))
 import           Control.Monad.IO.Class      (liftIO)
 import qualified Data.Text                   as T
 import           Development.IDE.GHC.Compat  (GhcVersion (..), ghcVersion)
 import           Development.IDE.GHC.Util
 import           Development.IDE.Test        (expectCurrentDiagnostics,
                                               expectDiagnostics,
                                               expectNoMoreDiagnostics)
+import qualified Language.LSP.Protocol.Lens  as L
 import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
                                               SemanticTokenRelative (..),
                                               SemanticTokensEdit (..), mkRange)
@@ -288,7 +291,23 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
     -- modify b too
     let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]
     changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource']
-    _ <- waitForDiagnostics
+
+    -- The reload renames THA's splice (th_a -> th) and re-splices it in THB.
+    -- While THA relinks, THB transiently reports "th_a not in scope", and a single
+    -- 'waitForDiagnostics' could catch that transient (see the note in Main.hs).
+    -- Wait for THB's own settled "Top-level binding" warning, matched on THB's uri.
+    let bUri = bdoc ^. L.uri
+        settledTHB params =
+          params ^. L.uri == bUri && case params ^. L.diagnostics of
+            [d] -> d ^. L.severity == Just DiagnosticSeverity_Warning
+                   && "Top-level binding" `T.isInfixOf` (d ^. L.message)
+            _   -> False
+        -- next PublishDiagnostics, skipping any non-diagnostic messages
+        nextPublishDiagnostics = publishDiagnosticsNotification <|> (anyMessage *> nextPublishDiagnostics)
+        waitForSettledTHB = do
+          notif <- nextPublishDiagnostics
+          if settledTHB (notif ^. L.params) then pure () else waitForSettledTHB
+    waitForSettledTHB
 
     expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")]
 

ghcide-test/exe/WatchedFileTests.hs

@@ -78,9 +78,9 @@ tests = testGroup "watched files"
           _ <- openDoc hsFile "haskell"
           expectDiagnostics [(hsFile, [(DiagnosticSeverity_Error, (2, 7), "Could not load module \8216Data.List.Split\8217", Nothing)])]
           let cabalFile = "reload.cabal"
-          cabalContent <- liftIO $ T.readFile cabalFile
+          cabalContent <- liftIO $ T.readFile (sessionDir </> cabalFile)
           let fix = T.replace "build-depends:    base" "build-depends:    base, split"
-          liftIO $ atomicFileWriteText cabalFile (fix cabalContent)
+          liftIO $ atomicFileWriteText (sessionDir </> cabalFile) (fix cabalContent)
           sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
             [ FileEvent (filePathToUri $ sessionDir </> cabalFile) FileChangeType_Changed ]
           expectDiagnostics [(hsFile, [])]

ghcide/session-loader/Development/IDE/Session/Ghc.hs

@@ -1,4 +1,4 @@
 {-# LANGUAGE CPP #-}
 module Development.IDE.Session.Ghc where
 
 import           Control.Monad
@@ -253,7 +253,7 @@
     where
       initMulti unitArgFiles =
         forM unitArgFiles $ \f -> do
-          args <- liftIO $ expandResponse [f]
+          args <- liftIO $ expandResponse [rebaseResponseFile compRoot f]
           -- The reponse files may contain arguments like "+RTS",
           -- and hie-bios doesn't expand the response files of @-unit@ arguments.
           -- Thus, we need to do the stripping here.
@@ -296,6 +296,13 @@
               dflags''
         return (HomeUnitConfig dflags''' targets mHash)
 
+-- | Rebase a relative @file response-file arg onto the component root, since
+-- 'expandResponse' would otherwise resolve it against the process CWD.
+rebaseResponseFile :: FilePath -> String -> String
+rebaseResponseFile root arg = case arg of
+  '@' : path -> '@' : toAbsolute root path
+  _          -> arg
+
 addComponentInfo ::
   MonadUnliftIO m =>
   Recorder (WithPriority Log) ->
@@ -450,9 +457,20 @@
 -- keeping the path short and clean.
 getCacheDirsDefault :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs
 getCacheDirsDefault prefix mFirstHash opts = do
-    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix' ++ "-" ++ opts_hash)
-    return $ CacheDirs dir dir dir
+    base <- getXdgDirectory XdgCache cacheDir
+    pure $ cacheDirsUnder base prefix mFirstHash opts
+
+-- | Like 'getCacheDirsDefault', but roots the cache under @base@ instead of
+-- 'XdgCache', so callers can isolate a cache without touching @XDG_CACHE_HOME@.
+getCacheDirsIn :: FilePath -> String -> Maybe B.ByteString -> [String] -> IO CacheDirs
+getCacheDirsIn base prefix mFirstHash opts =
+    pure $ cacheDirsUnder (base </> cacheDir) prefix mFirstHash opts
+
+-- | The per-component cache folder under @base@, see Note [Avoiding bad interface files].
+cacheDirsUnder :: FilePath -> String -> Maybe B.ByteString -> [String] -> CacheDirs
+cacheDirsUnder base prefix mFirstHash opts = CacheDirs dir dir dir
     where
+        dir = Just (base </> prefix' ++ "-" ++ opts_hash)
         -- Create a unique folder per set of different GHC options.
         prefix' = if isJust mFirstHash then "main" else prefix
         basectx = case mFirstHash of

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -112,6 +112,8 @@ data ServerLifecycleContext config = ServerLifecycleContext
     -- ^ Logger for recording server events and diagnostics
   , ctxDefaultRoot :: FilePath
     -- ^ Default root directory for the workspace, see Note [Root Directory]
+  , ctxDisableInitialCwdShift :: Bool
+    -- ^ Skip the init-time setCurrentDirectory so in-process test servers can run in parallel, see Note [Root Directory]
   , ctxGetHieDbLoc :: FilePath -> IO FilePath
     -- ^ Function to determine the HIE database location for a given root path
   , ctxGetIdeState :: LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState
@@ -191,12 +193,13 @@ setupLSP ::
      forall config.
      Recorder (WithPriority Log)
   -> FilePath -- ^ root directory, see Note [Root Directory]
+  -> Bool -- ^ disable the initial setCurrentDirectory to the rootUri (for parallel in-process tests)
   -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
   -> LSP.Handlers (ServerM config)
   -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)
   -> MVar ()
   -> IO (Setup config (ServerM config) IdeState)
-setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do
+setupLSP recorder defaultRoot disableInitialCwdShift getHieDbLoc userHandlers getIdeState clientMsgVar = do
   -- Send everything over a channel, since you need to wait until after initialise before
   -- LspFuncs is available
   clientMsgChan :: Chan ReactorMessage <- newChan
@@ -254,6 +257,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar
   let lifecycleCtx = ServerLifecycleContext
         { ctxRecorder = recorder
         , ctxDefaultRoot = defaultRoot
+        , ctxDisableInitialCwdShift = disableInitialCwdShift
         , ctxGetHieDbLoc = getHieDbLoc
         , ctxGetIdeState = getIdeState
         , ctxUntilReactorStopSignal = untilReactorStopSignal
@@ -285,7 +289,11 @@ handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "In
       untilReactorStopSignal = ctxUntilReactorStopSignal lifecycleCtx
       lifetimeConfirm = ctxConfirmReactorShutdown lifecycleCtx
     root <- case LSP.resRootPath env of
-      Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot
+      -- Skip the CWD shift under the test harness so in-process servers can run
+      -- in parallel. See Note [Root Directory].
+      Just lspRoot | lspRoot /= defaultRoot -> do
+        unless (ctxDisableInitialCwdShift lifecycleCtx) $ setCurrentDirectory lspRoot
+        return lspRoot
       _ -> pure defaultRoot
     dbLoc <- ctxGetHieDbLoc lifecycleCtx root
     let initConfig = parseConfiguration params