diff --git a/ghcide/test/exe/RootUriTests.hs b/ghcide/test/exe/RootUriTests.hs index 2237150508..2a9cb19ab1 100644 --- a/ghcide/test/exe/RootUriTests.hs +++ b/ghcide/test/exe/RootUriTests.hs @@ -7,20 +7,33 @@ import Development.IDE.Test (expectNoMoreDiagnostics) import Language.LSP.Test import System.FilePath -- import Test.QuickCheck.Instances () +import Config +import Data.Default (def) +import Test.Hls (TestConfig (..), + runSessionWithTestConfig) +import Test.Hls.FileSystem (copyDir) import Test.Tasty import Test.Tasty.HUnit -import TestUtils -- | checks if we use InitializeParams.rootUri for loading session tests :: TestTree tests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do let bPath = dir "dirB/Foo.hs" - liftIO $ copyTestDataFiles dir "rootUri" bSource <- liftIO $ readFileUtf8 bPath _ <- createDoc "Foo.hs" "haskell" bSource expectNoMoreDiagnostics 0.5 where -- similar to run' except we can configure where to start ghcide and session runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) + runTest dir1 dir2 = runSessionWithTestConfig + def + { + testPluginDescriptor = dummyPlugin + , testDirLocation = Right $ mkIdeTestFs [copyDir "rootUri"] + , testServerRoot = Just dir1 + , testClientRoot = Just dir2 + , testShiftRoot = True + } + + diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index cb566078b5..342677d872 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -474,6 +474,8 @@ runSessionWithServer config plugin fp act = instance Default (TestConfig b) where def = TestConfig { testDirLocation = Right $ VirtualFileTree [] "", + testClientRoot = Nothing, + testServerRoot = Nothing, testShiftRoot = False, testDisableKick = False, testDisableDefaultPlugin = False, @@ -618,6 +620,7 @@ lockForTempDirs = unsafePerformIO newLock data TestConfig b = TestConfig { testDirLocation :: Either FilePath VirtualFileTree + -- ^ Client capabilities -- ^ The file tree to use for the test, either a directory or a virtual file tree -- if using a virtual file tree, -- Creates a temporary directory, and materializes the VirtualFileTree @@ -638,6 +641,15 @@ data TestConfig b = TestConfig -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. , testShiftRoot :: Bool -- ^ Whether to shift the current directory to the root of the project + , testClientRoot :: Maybe FilePath + -- ^ Specify the root of (the client or LSP context), + -- if Nothing it is the same as the testDirLocation + -- if Just, it is subdirectory of the testDirLocation + , testServerRoot :: Maybe FilePath + -- ^ Specify root of the server, in exe, it can be specify in command line --cwd, + -- or just the server start directory + -- if Nothing it is the same as the testDirLocation + -- if Just, it is subdirectory of the testDirLocation , testDisableKick :: Bool -- ^ Whether to disable the kick action , testDisableDefaultPlugin :: Bool @@ -671,6 +683,8 @@ runSessionWithTestConfig TestConfig{..} session = runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do (inR, inW) <- createPipe (outR, outW) <- createPipe + let serverRoot = fromMaybe root testServerRoot + let clientRoot = fromMaybe root testClientRoot (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder @@ -685,11 +699,11 @@ runSessionWithTestConfig TestConfig{..} session = let plugins = testPluginDescriptor recorder <> lspRecorderPlugin timeoutOverride <- fmap read <$> lookupEnv "LSP_TIMEOUT" let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} - arguments = testingArgs root recorderIde plugins + arguments = testingArgs serverRoot recorderIde plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) arguments { argsHandleIn = pure inR , argsHandleOut = pure outW } - result <- runSessionWithHandles inW outR sconf' testConfigCaps root (session root) + result <- runSessionWithHandles inW outR sconf' testConfigCaps clientRoot (session root) hClose inW timeout 3 (wait server) >>= \case Just () -> pure ()