From 89ed1a640b00c37974aa3168634f5e809a0be86c Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Sun, 26 Dec 2021 12:44:57 -0500 Subject: [PATCH 1/2] Add new Ghcide Argument to track Project Root This commit provides an alternate way to grab the project root/current working directory. Prior to this commit the relative filepath "." was hard-coded for both Db and Custom Commands. This results in inconsistent behaviour with how HLS derives it's hiedb location. This new argument to the internal Ghcide Arguments, maps from the executable Arguments `argsCwd` or by grabbing the current working directory. If the user provides an option to `--cwd` we need to make sure we make that filepath absolute. Finally, inside the command handler, if necessary, we will grab the current working directory. We cannot provide a suitable default for this argument, therefore we leave it as a `Maybe FilePath`, even though this path should never be taken. --- ghcide/exe/Main.hs | 11 +++++++--- ghcide/src/Development/IDE/Main.hs | 34 +++++++++++++++++------------- 2 files changed, 27 insertions(+), 18 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 1e4f367140..8385a3d179 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -7,7 +7,7 @@ module Main(main) where import Arguments (Arguments (..), getArguments) -import Control.Monad.Extra (unless, whenJust) +import Control.Monad.Extra (unless) import Data.Default (def) import Data.Version (showVersion) import Development.GitRev (gitHash) @@ -50,13 +50,18 @@ main = withTelemetryLogger $ \telemetryLogger -> do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion - whenJust argsCwd IO.setCurrentDirectory + -- getHieDbLoc takes a directory path (the project root) and hashes it to find the location of the hiedb + -- when running commands directly from GHCIDE we need to provide the ABSOLUTE path to the project root (that's what HLS uses) + argsCwd <-case argsCwd of + Nothing -> IO.getCurrentDirectory + Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory let logPriority = if argsVerbose then Debug else Info arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority Main.defaultMain arguments - {Main.argCommand = argsCommand + { Main.argsProjectRoot = Just argsCwd + , Main.argCommand = argsCommand ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger ,Main.argsRules = do diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 541e7385b8..3c381bcc72 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -11,7 +11,8 @@ module Development.IDE.Main ,testing) where import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) -import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) +import Control.Concurrent.STM.Stats (atomically, + dumpSTMStats) import Control.Exception.Safe (Exception (displayException), catchAny) import Control.Monad.Extra (concatMapM, unless, @@ -56,6 +57,7 @@ import Development.IDE.Core.Shake (IdeState (shakeExtras), import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) +import Development.IDE.Main.HeapStats (withHeapStats) import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide @@ -77,12 +79,10 @@ import Development.IDE.Types.Options (IdeGhcSession, defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (Key(Key), - fromKeyType) +import Development.IDE.Types.Shake (Key (Key), fromKeyType) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) -import Development.IDE.Main.HeapStats (withHeapStats) import HIE.Bios.Cradle (findCradle) import qualified HieDb.Run as HieDb import Ide.Plugin.Config (CheckParents (NeverCheck), @@ -122,12 +122,12 @@ import Text.Printf (printf) data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures - | Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} + | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} -- ^ Run a command in the hiedb | LSP -- ^ Run the LSP server | PrintExtensionSchema | PrintDefaultConfig - | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand IdeState} -- ^ User defined + | Custom {ideCommand :: IdeCommand IdeState} -- ^ User defined deriving Show @@ -142,7 +142,7 @@ isLSP _ = False commandP :: IdePlugins IdeState -> Parser Command commandP plugins = hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo) - <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) + <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) <> command "lsp" (info (pure LSP <**> helper) lspInfo) <> command "vscode-extension-schema" extensionSchemaCommand <> command "generate-default-config" generateDefaultConfigCommand @@ -161,13 +161,14 @@ commandP plugins = (fullDesc <> progDesc "Print config supported by the server with default values") pluginCommands = mconcat - [ command (T.unpack pId) (Custom "." <$> p) + [ command (T.unpack pId) (Custom <$> p) | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins ] data Arguments = Arguments - { argsOTMemoryProfiling :: Bool + { argsProjectRoot :: Maybe FilePath + , argsOTMemoryProfiling :: Bool , argCommand :: Command , argsLogger :: IO Logger , argsRules :: Rules () @@ -189,7 +190,8 @@ instance Default Arguments where defaultArguments :: Priority -> Arguments defaultArguments priority = Arguments - { argsOTMemoryProfiling = False + { argsProjectRoot = Nothing + , argsOTMemoryProfiling = False , argCommand = LSP , argsLogger = stderrLogger priority , argsRules = mainRule def >> action kick @@ -380,16 +382,18 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger measureMemory logger [keys] consoleObserver values unless (null failed) (exitWith $ ExitFailure (length failed)) - Db dir opts cmd -> do - dbLoc <- getHieDbLoc dir + Db opts cmd -> do + root <- maybe IO.getCurrentDirectory return argsProjectRoot + dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags logger dir def + mlibdir <- setInitialDynFlags logger root def case mlibdir of Nothing -> exitWith $ ExitFailure 1 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd - Custom projectRoot (IdeCommand c) -> do - dbLoc <- getHieDbLoc projectRoot + Custom (IdeCommand c) -> do + root <- maybe IO.getCurrentDirectory return argsProjectRoot + dbLoc <- getHieDbLoc root runWithDb logger dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." From 875a1ce6b9f824feb9b4122d853422176ee462c1 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Tue, 28 Dec 2021 23:56:42 -0500 Subject: [PATCH 2/2] Fix Check commands handling of projectRoot. --- ghcide/exe/Main.hs | 5 ++--- ghcide/src/Development/IDE/Main.hs | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 8385a3d179..c743231255 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -50,9 +50,8 @@ main = withTelemetryLogger $ \telemetryLogger -> do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion - -- getHieDbLoc takes a directory path (the project root) and hashes it to find the location of the hiedb - -- when running commands directly from GHCIDE we need to provide the ABSOLUTE path to the project root (that's what HLS uses) - argsCwd <-case argsCwd of + -- if user uses --cwd option we need to make this path absolute (and set the current directory to it) + argsCwd <- case argsCwd of Nothing -> IO.getCurrentDirectory Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 3c381bcc72..7d89e3a909 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -319,7 +319,7 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger hieChan dumpSTMStats Check argFiles -> do - dir <- IO.getCurrentDirectory + dir <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc dir runWithDb logger dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error