fix uses of getCurrentDirectory in ghcide

haskell · Jun 6, 2021 · 41a3c7f · 41a3c7f
1 parent 1e25507
commit 41a3c7f
Show file tree

Hide file tree

Showing 3 changed files with 13 additions and 15 deletions.
diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/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,
@@ -151,26 +151,25 @@ loadWithImplicitCradle mHieYaml rootDir = do
         setCurrentDirectory rootDir
         loadImplicitHieCradle $ addTrailingPathSeparator rootDir
 
-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

diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/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

diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs
@@ -206,14 +206,14 @@ defaultMain Arguments{..} = do
                 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)
 
 
@@ -307,7 +307,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