Migrate RootUriTests (#4261)

* Migrate RootUriTests

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
+ }
+
+

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 ()