Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix ghcide handling project root #2543

Merged
merged 5 commits into from
Jan 4, 2022
Merged

Fix ghcide handling project root #2543

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
89ed1a6
Add new Ghcide Argument to track Project Root
drsooch Dec 26, 2021
875a1ce
Fix Check commands handling of projectRoot.
drsooch Dec 29, 2021
f8ab5fa
Merge branch 'origin-master' into fix-ghcide-handling-project-root
drsooch Dec 29, 2021
71671f6
Merge branch 'master' into fix-ghcide-handling-project-root
pepeiborra Dec 30, 2021
7f8e5ed
Merge branch 'master' into fix-ghcide-handling-project-root
Anton-Latukha Jan 3, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 7 additions & 3 deletions ghcide/exe/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -50,13 +50,17 @@ main = withTelemetryLogger $ \telemetryLogger -> do
if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion

whenJust argsCwd IO.setCurrentDirectory
-- 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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is a little obscure: why not just call makeAbsolute on root? This relies on you knowing that getCurrentDirectory returns an absolute path.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

You're right and I originally did it that way, but I wanted to match the semantics found throughout out the codebase. For example, in Development.IDE.Main.defaultMain all of the argCommands use the same maybe IO.getCurrentDirectory return rootPath expression to get the project root.


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
Expand Down
28 changes: 16 additions & 12 deletions ghcide/src/Development/IDE/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -124,12 +124,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
pepeiborra marked this conversation as resolved.
Show resolved Hide resolved
deriving Show


Expand All @@ -144,7 +144,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
Expand All @@ -163,13 +163,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 ()
Expand All @@ -191,7 +192,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
Expand Down Expand Up @@ -319,7 +321,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
Expand Down Expand Up @@ -382,17 +384,19 @@ 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
rng <- newStdGen
case mlibdir of
Nothing -> exitWith $ ExitFailure 1
Just libdir -> retryOnSqliteBusy logger rng (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 "."
Expand Down