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