Fix getCurrentDirectory calls in ghcide

ghcide/session-loader/Development/IDE/Session.hs

@@ -106,7 +106,7 @@ data SessionLoadingOptions = SessionLoadingOptions
   --   or 'Nothing' to respect the cradle setting
   , getCacheDirs           :: String -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
-  , getInitialGhcLibDir    :: IO (Maybe LibDir)
+  , getInitialGhcLibDir    :: FilePath -> IO (Maybe LibDir)
   , fakeUid                :: GHC.InstalledUnitId
     -- ^ unit id used to tag the internal component built by ghcide
     --   To reuse external interface files the unit ids must match,
@@ -140,31 +140,29 @@ loadWithImplicitCradle :: Maybe FilePath
                           -- if no 'hie.yaml' location is given.
                           -> IO (HieBios.Cradle Void)
 loadWithImplicitCradle mHieYaml rootDir = do
-  crdl       <- case mHieYaml of
+  case mHieYaml of
     Just yaml -> HieBios.loadCradle yaml
     Nothing   -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir
-  return crdl
 
-getInitialGhcLibDirDefault :: IO (Maybe LibDir)
-getInitialGhcLibDirDefault = do
-  dir <- IO.getCurrentDirectory
-  hieYaml <- findCradle def dir
-  cradle <- loadCradle def hieYaml dir
+getInitialGhcLibDirDefault :: FilePath -> IO (Maybe LibDir)
+getInitialGhcLibDirDefault rootDir = do
+  hieYaml <- findCradle def rootDir
+  cradle <- loadCradle def hieYaml rootDir
   hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
   libDirRes <- getRuntimeGhcLibDir cradle
   case libDirRes of
       CradleSuccess libdir -> pure $ Just $ LibDir libdir
       CradleFail err -> do
-        hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle)
+        hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle)
         pure Nothing
       CradleNone -> do
         hPutStrLn stderr "Couldn't load cradle (CradleNone)"
         pure Nothing
 
 -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
-setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir)
-setInitialDynFlags SessionLoadingOptions{..} = do
-  libdir <- getInitialGhcLibDir
+setInitialDynFlags :: FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
+setInitialDynFlags rootDir SessionLoadingOptions{..} = do
+  libdir <- getInitialGhcLibDir rootDir
   dynFlags <- mapM dynFlagsForPrinting libdir
   mapM_ setUnsafeGlobalDynFlags dynFlags
   pure libdir
@@ -423,6 +421,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
              logWarning logger $ implicitCradleWarning lfp
 
            cradle <- loadCradle hieYaml dir
+           lfp <- flip makeRelative cfp <$> getCurrentDirectory
 
            when optTesting $ mRunLspT lspEnv $
             sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp)

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

@@ -122,8 +122,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
         handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
             traceWithSpan sp params
             let root = LSP.resRootPath env
-
-            dir <- getCurrentDirectory
+            dir <- maybe getCurrentDirectory return root
             dbLoc <- getHieDbLoc dir
 
             -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference

ghcide/src/Development/IDE/Main.hs

@@ -14,12 +14,12 @@ import           Control.Exception.Safe                (Exception (displayExcept
 import           Control.Monad.Extra                   (concatMapM, unless,
                                                         when)
 import           Data.Default                          (Default (def))
+import           Data.Foldable                         (traverse_)
 import qualified Data.HashMap.Strict                   as HashMap
 import           Data.Hashable                         (hashed)
 import           Data.List.Extra                       (intercalate, isPrefixOf,
                                                         nub, nubOrd, partition)
-import           Data.Maybe                            (catMaybes, fromMaybe,
-                                                        isJust)
+import           Data.Maybe                            (catMaybes, isJust)
 import qualified Data.Text                             as T
 import qualified Data.Text.IO                          as T
 import           Development.IDE                       (Action, Rules,
@@ -203,21 +203,20 @@ defaultMain Arguments{..} = do
             hPutStrLn stderr "Starting LSP server..."
             hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
             runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
+                traverse_ IO.setCurrentDirectory rootPath
                 t <- t
                 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
 
-                dir <- IO.getCurrentDirectory
+                dir <- maybe IO.getCurrentDirectory return rootPath
 
                 -- We want to set the global DynFlags right now, so that we can use
                 -- `unsafeGlobalDynFlags` even before the project is configured
-                -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
-                -- before calling this function
                 _mlibdir <-
-                    setInitialDynFlags argsSessionLoadingOptions
+                    setInitialDynFlags dir argsSessionLoadingOptions
                         `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
 
 
-                sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath
+                sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir
                 config <- LSP.runLspT env LSP.getConfig
                 let def_options = argsIdeOptions config sessionLoader
 
@@ -307,7 +306,7 @@ defaultMain Arguments{..} = do
         Db dir opts cmd -> do
             dbLoc <- getHieDbLoc dir
             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
-            mlibdir <- setInitialDynFlags def
+            mlibdir <- setInitialDynFlags dir def
             case mlibdir of
                 Nothing     -> exitWith $ ExitFailure 1
                 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd