[Migrate BootTests] part of #4173 Migrate ghcide tests to hls test ut…

…ils (#4227) * migrate boot test * add comment
haskell · May 14, 2024 · a1fe52f · a1fe52f
1 parent 4985793
commit a1fe52f
Show file tree

Hide file tree

Showing 3 changed files with 35 additions and 8 deletions.
diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs
@@ -1,6 +1,7 @@
 module BootTests (tests) where
 
-import           Config                          (checkDefs, mkR)
+import           Config                          (checkDefs, mkR, runInDir,
+                                                  runWithExtraFiles)
 import           Control.Applicative.Combinators
 import           Control.Monad
 import           Control.Monad.IO.Class          (liftIO)
@@ -15,16 +16,15 @@ import           Language.LSP.Protocol.Types     hiding
                                                   SemanticTokensEdit (..),
                                                   mkRange)
 import           Language.LSP.Test
-import           System.FilePath
+import           Test.Hls.FileSystem             (toAbsFp)
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
 
 
 tests :: TestTree
 tests = testGroup "boot"
   [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do
-        let cPath = dir </> "C.hs"
+        let cPath = dir `toAbsFp` "C.hs"
         cSource <- liftIO $ readFileUtf8 cPath
         -- Dirty the cache
         liftIO $ runInDir dir $ do
@@ -51,6 +51,6 @@ tests = testGroup "boot"
         let floc = mkR 9 0 9 1
         checkDefs locs (pure [floc])
   , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do
-      _ <- openDoc (dir </> "A.hs") "haskell"
+      _ <- openDoc (dir `toAbsFp` "A.hs") "haskell"
       expectNoMoreDiagnostics 2
   ]
diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs
@@ -13,6 +13,7 @@ module Config(
     , testWithDummyPluginEmpty'
     , testWithDummyPluginAndCap'
     , runWithExtraFiles
+    , runInDir
     , testWithExtraFiles
 
     -- * utilities for testing definition and hover
@@ -36,7 +37,7 @@ import           Language.LSP.Protocol.Types (Null (..))
 import           System.FilePath             ((</>))
 import           Test.Hls
 import qualified Test.Hls.FileSystem         as FS
-import           Test.Hls.FileSystem         (FileSystem)
+import           Test.Hls.FileSystem         (FileSystem, fsRoot)
 
 testDataDir :: FilePath
 testDataDir = "ghcide" </> "test" </> "data"
@@ -80,6 +81,9 @@ runWithExtraFiles dirName action = do
 testWithExtraFiles :: String -> String -> (FileSystem -> Session ()) -> TestTree
 testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action
 
+runInDir :: FileSystem -> Session a -> IO a
+runInDir fs = runSessionWithServerNoRootLock False dummyPlugin def def def (fsRoot fs)
+
 pattern R :: UInt -> UInt -> UInt -> UInt -> Range
 pattern R x y x' y' = Range (Position x y) (Position x' y')
 

diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs
@@ -31,6 +31,7 @@ module Test.Hls
     runSessionWithServerAndCaps,
     runSessionWithServerInTmpDir,
     runSessionWithServerAndCapsInTmpDir,
+    runSessionWithServerNoRootLock,
     runSessionWithServer',
     runSessionWithServerInTmpDir',
     -- continuation version that take a FileSystem
@@ -618,7 +619,10 @@ lockForTempDirs = unsafePerformIO newLock
 
 -- | Host a server, and run a test session on it
 -- Note: cwd will be shifted into @root@ in @Session a@
-runSessionWithServer' ::
+-- notice this function should only be used in tests that
+-- require to be nested in the same temporary directory
+-- use 'runSessionWithServerInTmpDir' for other cases
+runSessionWithServerNoRootLock ::
   (Pretty b) =>
   -- | whether we disable the kick action or not
   Bool ->
@@ -632,7 +636,7 @@ runSessionWithServer' ::
   FilePath ->
   Session a ->
   IO a
-runSessionWithServer' disableKick pluginsDp conf sconf caps root s =  withLock lock $ keepCurrentDirectory $ do
+runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s =  do
     (inR, inW) <- createPipe
     (outR, outW) <- createPipe
 
@@ -676,6 +680,25 @@ runSessionWithServer' disableKick pluginsDp conf sconf caps root s =  withLock l
             putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)"
     pure x
 
+-- | Host a server, and run a test session on it
+-- Note: cwd will be shifted into @root@ in @Session a@
+runSessionWithServer' ::
+  (Pretty b) =>
+  -- | whether we disable the kick action or not
+  Bool ->
+  -- | Plugin to load on the server.
+  PluginTestDescriptor b ->
+  -- | lsp config for the server
+  Config ->
+  -- | config for the test session
+  SessionConfig ->
+  ClientCapabilities ->
+  FilePath ->
+  Session a ->
+  IO a
+runSessionWithServer' disableKick pluginsDp conf sconf caps root s =
+    withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s
+
 -- | Wait for the next progress begin step
 waitForProgressBegin :: Session ()
 waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case