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.

Author: drsooch

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

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 "."