fix hls

Author: soulomoon

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

@@ -125,15 +125,16 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh
 
 setupLSP ::
      forall config err.
-     Recorder (WithPriority Log)
+     FilePath -- ^ root directory
+  -> Recorder (WithPriority Log)
   -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
   -> LSP.Handlers (ServerM config)
   -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
   -> MVar ()
   -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
          LSP.Handlers (ServerM config),
          (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
-setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
+setupLSP root recorder 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
@@ -176,15 +177,16 @@ setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
         -- Cancel requests are special since they need to be handled
         -- out of order to be useful. Existing handlers are run afterwards.
 
-  let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan
+  let doInitialize = handleInit root recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan
 
   let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO
 
   pure (doInitialize, asyncHandlers, interpretHandler)
 
 
 handleInit
-    :: Recorder (WithPriority Log)
+    :: FilePath
+    -> Recorder (WithPriority Log)
     -> (FilePath -> IO FilePath)
     -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
     -> MVar ()
@@ -193,11 +195,9 @@ handleInit
     -> (SomeLspId -> IO ())
     -> Chan ReactorMessage
     -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
-handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
+handleInit rootDir recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
     traceWithSpan sp params
-    let root = LSP.resRootPath env
-    dir <- maybe (error "No root directory") pure root
-    dbLoc <- getHieDbLoc dir
+    dbLoc <- getHieDbLoc rootDir
     let initConfig = parseConfiguration params
     logWith recorder Info $ LogRegisteringIdeConfig initConfig
     dbMVar <- newEmptyMVar
@@ -240,7 +240,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
         logWith recorder Info LogReactorThreadStopped
 
     (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar
-    ide <- getIdeState env dir withHieDb hieChan
+    ide <- getIdeState env rootDir withHieDb hieChan
     registerIdeConfiguration (shakeExtras ide) initConfig
     pure $ Right (env,ide)
 

ghcide/src/Development/IDE/Main.hs

@@ -357,7 +357,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                   putMVar ideStateVar ide
                   pure ide
 
-            let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState
+            let setup = setupLSP argsProjectRoot (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState
                 -- See Note [Client configuration in Rules]
                 onConfigChange cfg = do
                   -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint

hls-test-utils/src/Test/Hls.hs

@@ -415,6 +415,33 @@ runSessionWithServerInTmpDir' ::
     Session a -> IO a
 runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act)
 
+runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) ->  IO a
+runWithLockInTempDir tree act = withLock lockForTempDirs $ do
+    testRoot <- setupTestEnvironment
+    helperRecorder <- hlsHelperTestRecorder
+    -- Do not clean up the temporary directory if this variable is set to anything but '0'.
+    -- Aids debugging.
+    cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP"
+    let runTestInDir action = case cleanupTempDir of
+            Just val | val /= "0" -> do
+                (tempDir, _) <- newTempDirWithin testRoot
+                a <- action tempDir
+                logWith helperRecorder Debug LogNoCleanup
+                pure a
+
+            _ -> do
+                (tempDir, cleanup) <- newTempDirWithin testRoot
+                a <- action tempDir `finally` cleanup
+                logWith helperRecorder Debug LogCleanup
+                pure a
+    runTestInDir $ \tmpDir' -> do
+        -- we canonicalize the path, so that we do not need to do
+        -- cannibalization during the test when we compare two paths
+        tmpDir <- canonicalizePath tmpDir'
+        logWith helperRecorder Info $ LogTestDir tmpDir
+        fs <- FS.materialiseVFT tmpDir tree
+        act fs
+
 -- | Host a server, and run a test session on it.
 --
 -- Creates a temporary directory, and materializes the VirtualFileTree
@@ -449,33 +476,8 @@ runSessionWithServerInTmpDirCont ::
     ClientCapabilities ->
     VirtualFileTree ->
     (FileSystem -> Session a) -> IO a
-runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = withLock lockForTempDirs $ do
-    testRoot <- setupTestEnvironment
-    helperRecorder <- hlsHelperTestRecorder
-
-    -- Do not clean up the temporary directory if this variable is set to anything but '0'.
-    -- Aids debugging.
-    cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP"
-    let runTestInDir action = case cleanupTempDir of
-            Just val | val /= "0" -> do
-                (tempDir, _) <- newTempDirWithin testRoot
-                a <- action tempDir
-                logWith helperRecorder Debug LogNoCleanup
-                pure a
-
-            _ -> do
-                (tempDir, cleanup) <- newTempDirWithin testRoot
-                a <- action tempDir `finally` cleanup
-                logWith helperRecorder Debug LogCleanup
-                pure a
-
-    runTestInDir $ \tmpDir' -> do
-        -- we canonicalize the path, so that we do not need to do
-        -- cannibalization during the test when we compare two paths
-        tmpDir <- canonicalizePath tmpDir'
-        logWith helperRecorder Info $ LogTestDir tmpDir
-        fs <- FS.materialiseVFT tmpDir tree
-        runSessionWithServer' disableKick plugins conf sessConf caps tmpDir (act fs)
+runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act =
+    runWithLockInTempDir tree $ \fs -> runSessionWithServer' disableKick plugins conf sessConf caps (fsRoot fs) (act fs)
 
 runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a
 runSessionWithServer config plugin fp act = do

plugins/hls-splice-plugin/test/Main.hs

@@ -89,7 +89,7 @@ goldenTestWithEdit fp expect tc line col =
          }
      waitForAllProgressDone -- cradle
      waitForAllProgressDone
-     alt <- liftIO $ T.readFile (fp <.> "error.hs")
+     alt <- liftIO $ T.readFile (testDataDir </> fp <.> "error.hs")
      void $ applyEdit doc $ TextEdit theRange alt
      changeDoc doc [TextDocumentContentChangeEvent $ InL
         TextDocumentContentChangePartial {_range = theRange, _rangeLength = Nothing, _text = alt}