From 6b8d6c65ffddb4f9d5deb909e149c5056eaa0154 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 15 Feb 2021 16:48:47 +0530 Subject: [PATCH 1/6] Add test for multi-component goto def and make runLanguageServer responsible for hiedb --- ghcide/exe/Main.hs | 78 +++++++++---------- .../src/Development/IDE/LSP/LanguageServer.hs | 22 +++++- ghcide/src/Development/IDE/Main.hs | 24 +++--- ghcide/test/exe/Main.hs | 24 +++++- src/Ide/Main.hs | 29 ++++--- 5 files changed, 105 insertions(+), 72 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index bcd93bca25..09bae9405e 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -20,7 +20,7 @@ import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb) +import Development.IDE.Session (setInitialDynFlags, getHieDbLoc) import Development.IDE.Types.Options import qualified Development.IDE.Main as Main import Development.Shake (ShakeOptions(shakeThreads)) @@ -56,9 +56,6 @@ main = do whenJust argsCwd IO.setCurrentDirectory - dir <- IO.getCurrentDirectory - dbLoc <- getHieDbLoc dir - -- lock to avoid overlapping output on stdout lock <- newLock let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $ @@ -67,6 +64,8 @@ main = do case argFilesOrCmd of DbCmd opts cmd -> do + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir mlibdir <- setInitialDynFlags case mlibdir of Nothing -> exitWith $ ExitFailure 1 @@ -80,40 +79,39 @@ main = do hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" _ -> return () - runWithDb dbLoc $ \hiedb hiechan -> - Main.defaultMain (Main.defArguments hiedb hiechan) - {Main.argFiles = case argFilesOrCmd of - Typecheck x | not argLSP -> Just x - _ -> Nothing - - ,Main.argsLogger = logger - - ,Main.argsRules = do - -- install the main and ghcide-plugin rules - mainRule - -- install the kick action, which triggers a typecheck on every - -- Shake database restart, i.e. on every user edit. - unless argsDisableKick $ - action kick - - ,Main.argsHlsPlugins = - pluginDescToIdePlugins $ - GhcIde.descriptors - ++ [Test.blockCommandDescriptor "block-command" | argsTesting] - - ,Main.argsGhcidePlugin = if argsTesting - then Test.plugin - else mempty - - ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader -> - let defOptions = defaultIdeOptions sessionLoader - in defOptions - { optShakeProfiling = argsShakeProfiling - , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , optTesting = IdeTesting argsTesting - , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} - , optCheckParents = pure $ checkParents config - , optCheckProject = pure $ checkProject config - } - } + Main.defaultMain Main.defArguments + {Main.argFiles = case argFilesOrCmd of + Typecheck x | not argLSP -> Just x + _ -> Nothing + + ,Main.argsLogger = logger + + ,Main.argsRules = do + -- install the main and ghcide-plugin rules + mainRule + -- install the kick action, which triggers a typecheck on every + -- Shake database restart, i.e. on every user edit. + unless argsDisableKick $ + action kick + + ,Main.argsHlsPlugins = + pluginDescToIdePlugins $ + GhcIde.descriptors + ++ [Test.blockCommandDescriptor "block-command" | argsTesting] + + ,Main.argsGhcidePlugin = if argsTesting + then Test.plugin + else mempty + + ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader -> + let defOptions = defaultIdeOptions sessionLoader + in defOptions + { optShakeProfiling = argsShakeProfiling + , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling + , optTesting = IdeTesting argsTesting + , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} + , optCheckParents = pure $ checkParents config + , optCheckProject = pure $ checkProject config + } + } diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index bc5780e1b1..d7a5482b24 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -28,9 +28,12 @@ import Control.Monad.Extra import UnliftIO.Exception import UnliftIO.Async import UnliftIO.Concurrent +import UnliftIO.MVar +import UnliftIO.Directory import Control.Monad.IO.Class import Control.Monad.Reader import Ide.Types (traceWithSpan) +import Development.IDE.Session (runWithDb, getHieDbLoc) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake @@ -40,12 +43,14 @@ import Development.IDE.Types.Logger import Development.IDE.Core.FileStore import Development.IDE.Core.Tracing +import System.IO.Unsafe (unsafeInterleaveIO) + runLanguageServer :: forall config. (Show config) => LSP.Options -> (IdeState -> Value -> IO (Either T.Text config)) -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> IO IdeState) + -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState) -> IO () runLanguageServer options onConfigurationChange userHandlers getIdeState = do -- Move stdout to another file descriptor and duplicate stderr @@ -134,13 +139,24 @@ runLanguageServer options onConfigurationChange userHandlers getIdeState = do handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do liftIO $ traceWithSpan sp params let root = LSP.resRootPath env - ide <- liftIO $ getIdeState env (makeLSPVFSHandle env) root + + dir <- getCurrentDirectory + dbLoc <- liftIO $ getHieDbLoc dir + + -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference + -- to 'getIdeState', so we use this dirty trick + dbMVar <- newEmptyMVar + ~(hiedb,hieChan) <- liftIO $ unsafeInterleaveIO $ takeMVar dbMVar + + ide <- liftIO $ getIdeState env (makeLSPVFSHandle env) root hiedb hieChan let initConfig = parseConfiguration params liftIO $ logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig liftIO $ registerIdeConfiguration (shakeExtras ide) initConfig - _ <- flip forkFinally (const exitClientMsg) $ forever $ do + _ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do + putMVar dbMVar (hiedb,hieChan) + forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously -- This is to ensure that all file edits and config changes are applied before a request is handled diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 4164ce201f..d30b72aaef 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -49,7 +49,7 @@ import Development.IDE.Plugin ( Plugin (pluginHandlers, pluginRules), ) import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags) +import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb) import Development.IDE.Types.Location (toNormalizedFilePath') import Development.IDE.Types.Logger (Logger) import Development.IDE.Types.Options ( @@ -77,8 +77,6 @@ data Arguments = Arguments { argsOTMemoryProfiling :: Bool , argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit , argsLogger :: Logger - , argsHiedb :: HieDb - , argsHieChan :: IndexQueue , argsRules :: Rules () , argsHlsPlugins :: IdePlugins IdeState , argsGhcidePlugin :: Plugin Config -- ^ Deprecated @@ -88,14 +86,12 @@ data Arguments = Arguments , argsDefaultHlsConfig :: Config } -defArguments :: HieDb -> IndexQueue -> Arguments -defArguments hiedb hiechan = +defArguments :: Arguments +defArguments = Arguments { argsOTMemoryProfiling = False , argFiles = Nothing , argsLogger = noLogging - , argsHiedb = hiedb - , argsHieChan = hiechan , argsRules = mainRule >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors @@ -107,7 +103,6 @@ defArguments hiedb hiechan = defaultMain :: Arguments -> IO () defaultMain Arguments{..} = do - dir <- IO.getCurrentDirectory pid <- T.pack . show <$> getProcessID let hlsPlugin = asGhcIdePlugin argsHlsPlugins @@ -121,10 +116,12 @@ defaultMain Arguments{..} = do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer options argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath -> do + runLanguageServer options argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t + dir <- IO.getCurrentDirectory + -- 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') @@ -148,9 +145,12 @@ defaultMain Arguments{..} = do debouncer options vfs - argsHiedb - argsHieChan + hiedb + hieChan Just argFiles -> do + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + runWithDb dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -178,7 +178,7 @@ defaultMain Arguments{..} = do { optCheckParents = pure NeverCheck , optCheckProject = pure False } - ide <- initialise mainRule Nothing argsLogger debouncer options vfs argsHiedb argsHieChan + ide <- initialise mainRule Nothing argsLogger debouncer options vfs hiedb hieChan putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index a3c5e0f523..2ccd2a8940 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4343,7 +4343,7 @@ cradleTests = testGroup "cradle" [testGroup "dependencies" [sessionDepsArePickedUp] ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest] ,testGroup "sub-directory" [simpleSubDirectoryTest] ] @@ -4503,6 +4503,28 @@ simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \ checkDefs locs (pure [fooL]) expectNoMoreDiagnostics 0.5 +-- Like simpleMultiTest but open the files in component 'a' in a seperate session +simpleMultiDefTest :: TestTree +simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- liftIO $ runInDir dir $ do + aSource <- liftIO $ readFileUtf8 aPath + adoc <- createDoc aPath "haskell" aSource + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do + A.Success fp' <- pure $ fromJSON fp + if fp' == aPath then pure () else Nothing + _ -> Nothing + closeDoc adoc + pure adoc + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + ifaceTests :: TestTree ifaceTests = testGroup "Interface loading tests" [ -- https://github.com/haskell/ghcide/pull/645/ diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index ee36576843..17d8979783 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -82,8 +82,6 @@ hlsLogger = G.Logger $ \pri txt -> runLspMode :: LspArguments -> IdePlugins IdeState -> IO () runLspMode lspArgs@LspArguments{..} idePlugins = do whenJust argsCwd IO.setCurrentDirectory - dir <- IO.getCurrentDirectory - dbLoc <- getHieDbLoc dir LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO @@ -94,17 +92,16 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do hPutStrLn stderr $ " in directory: " <> dir hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runWithDb dbLoc $ \hiedb hiechan -> - Main.defaultMain (Main.defArguments hiedb hiechan) - { Main.argFiles = if argLSP then Nothing else Just [] - , Main.argsHlsPlugins = idePlugins - , Main.argsLogger = hlsLogger - , Main.argsIdeOptions = \_config sessionLoader -> - let defOptions = Ghcide.defaultIdeOptions sessionLoader - in defOptions - { Ghcide.optShakeProfiling = argsShakeProfiling - , Ghcide.optTesting = Ghcide.IdeTesting argsTesting - , Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions) - {shakeThreads = argsThreads} - } - } + Main.defaultMain Main.defArguments + { Main.argFiles = if argLSP then Nothing else Just [] + , Main.argsHlsPlugins = idePlugins + , Main.argsLogger = hlsLogger + , Main.argsIdeOptions = \_config sessionLoader -> + let defOptions = Ghcide.defaultIdeOptions sessionLoader + in defOptions + { Ghcide.optShakeProfiling = argsShakeProfiling + , Ghcide.optTesting = Ghcide.IdeTesting argsTesting + , Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions) + {shakeThreads = argsThreads} + } + } From 5d94b3b1a30dc53f644bc0cef192bae1e9ada9d9 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 15 Feb 2021 17:09:28 +0530 Subject: [PATCH 2/6] cleanup --- .../src/Development/IDE/LSP/LanguageServer.hs | 21 +++++++++---------- ghcide/src/Development/IDE/Main.hs | 2 -- src/Ide/Main.hs | 3 ++- 3 files changed, 12 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index d7a5482b24..22fc718828 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -28,7 +28,6 @@ import Control.Monad.Extra import UnliftIO.Exception import UnliftIO.Async import UnliftIO.Concurrent -import UnliftIO.MVar import UnliftIO.Directory import Control.Monad.IO.Class import Control.Monad.Reader @@ -137,22 +136,22 @@ runLanguageServer options onConfigurationChange userHandlers getIdeState = do :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do - liftIO $ traceWithSpan sp params + traceWithSpan sp params let root = LSP.resRootPath env dir <- getCurrentDirectory - dbLoc <- liftIO $ getHieDbLoc dir + dbLoc <- getHieDbLoc dir -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference -- to 'getIdeState', so we use this dirty trick dbMVar <- newEmptyMVar - ~(hiedb,hieChan) <- liftIO $ unsafeInterleaveIO $ takeMVar dbMVar + ~(hiedb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - ide <- liftIO $ getIdeState env (makeLSPVFSHandle env) root hiedb hieChan + ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan let initConfig = parseConfiguration params - liftIO $ logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig - liftIO $ registerIdeConfiguration (shakeExtras ide) initConfig + logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + registerIdeConfiguration (shakeExtras ide) initConfig _ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) @@ -174,20 +173,20 @@ runLanguageServer options onConfigurationChange userHandlers getIdeState = do :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId -> IO () -> (ResponseError -> IO ()) -> IO () checkCancelled ide clearReqId waitForCancel _id act k = - flip finally (liftIO $ clearReqId _id) $ + flip finally (clearReqId _id) $ catch (do -- We could optimize this by first checking if the id -- is in the cancelled set. However, this is unlikely to be a -- bottleneck and the additional check might hide -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (liftIO $ waitForCancel _id) act + cancelOrRes <- race (waitForCancel _id) act case cancelOrRes of Left () -> do - liftIO $ logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id k $ ResponseError RequestCancelled "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do - liftIO $ logError (ideLogger ide) $ T.pack $ + logError (ideLogger ide) $ T.pack $ "Unexpected exception on request, please report!\n" ++ "Exception: " ++ show e k $ ResponseError InternalError (T.pack $ show e) Nothing diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index d30b72aaef..2013226af7 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -37,9 +37,7 @@ import Development.IDE.Core.Rules ( ) import Development.IDE.Core.Service (initialise, runAction) import Development.IDE.Core.Shake ( - HieDb, IdeState (shakeExtras), - IndexQueue, ShakeExtras (state), uses, ) diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 17d8979783..09157fed9e 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -16,7 +16,7 @@ import Control.Monad.Extra import qualified Data.Map.Strict as Map import qualified Data.Text as T import Development.IDE.Core.Rules -import Development.IDE.Session (setInitialDynFlags, getHieDbLoc, runWithDb) +import Development.IDE.Session (setInitialDynFlags, getHieDbLoc) import Development.IDE.Types.Logger as G import qualified Language.LSP.Server as LSP import Ide.Arguments @@ -82,6 +82,7 @@ hlsLogger = G.Logger $ \pri txt -> runLspMode :: LspArguments -> IdePlugins IdeState -> IO () runLspMode lspArgs@LspArguments{..} idePlugins = do whenJust argsCwd IO.setCurrentDirectory + dir <- IO.getCurrentDirectory LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO From 3e5207ea0f9cf751c240dc78769ce602d19c6158 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 15 Feb 2021 17:11:35 +0530 Subject: [PATCH 3/6] fix hlint --- ghcide/.hlint.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 1829f648ff..2e3099223b 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -105,7 +105,7 @@ # - functions: # Things that are unsafe in Haskell base library - - {name: unsafeInterleaveIO, within: []} + - {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]} - {name: unsafeDupablePerformIO, within: []} - {name: unsafeCoerce, within: []} # Things that are a bit dangerous in the GHC API From 6b0322b9a043bdccbee3b7016646222765ee09de Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 15 Feb 2021 20:32:36 +0530 Subject: [PATCH 4/6] debug windows --- ghcide/test/exe/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 2ccd2a8940..37966fd94c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4511,6 +4511,7 @@ simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi adoc <- liftIO $ runInDir dir $ do aSource <- liftIO $ readFileUtf8 aPath adoc <- createDoc aPath "haskell" aSource + liftIO $ hPutStrLn stderr $ "Looking for references/ready from: " ++ aPath ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do A.Success fp' <- pure $ fromJSON fp From 5f41dd627e05ffa9a28b1e78437f6dac3752f5b4 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 15 Feb 2021 22:55:07 +0530 Subject: [PATCH 5/6] fix windows test --- ghcide/test/exe/Main.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 37966fd94c..831acf2e93 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4511,11 +4511,10 @@ simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi adoc <- liftIO $ runInDir dir $ do aSource <- liftIO $ readFileUtf8 aPath adoc <- createDoc aPath "haskell" aSource - liftIO $ hPutStrLn stderr $ "Looking for references/ready from: " ++ aPath ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do A.Success fp' <- pure $ fromJSON fp - if fp' == aPath then pure () else Nothing + if equalFilePath fp' aPath then pure () else Nothing _ -> Nothing closeDoc adoc pure adoc From 1f42e2091efcc2f5f02a369e9b8148b9d572a5a2 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 16 Feb 2021 01:02:01 +0530 Subject: [PATCH 6/6] make hiedb location configurable --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 5 +++-- ghcide/src/Development/IDE/Main.hs | 4 +++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 22fc718828..d8f9c1a1a8 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -32,7 +32,7 @@ import UnliftIO.Directory import Control.Monad.IO.Class import Control.Monad.Reader import Ide.Types (traceWithSpan) -import Development.IDE.Session (runWithDb, getHieDbLoc) +import Development.IDE.Session (runWithDb) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake @@ -47,11 +47,12 @@ import System.IO.Unsafe (unsafeInterleaveIO) runLanguageServer :: forall config. (Show config) => LSP.Options + -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> (IdeState -> Value -> IO (Either T.Text config)) -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState) -> IO () -runLanguageServer options onConfigurationChange userHandlers getIdeState = do +runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeState = do -- Move stdout to another file descriptor and duplicate stderr -- to stdout. This guards against stray prints from corrupting the JSON-RPC -- message stream. diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 2013226af7..01e4a14743 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -82,6 +82,7 @@ data Arguments = Arguments , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions , argsLspOptions :: LSP.Options , argsDefaultHlsConfig :: Config + , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project } defArguments :: Arguments @@ -97,6 +98,7 @@ defArguments = , argsIdeOptions = const defaultIdeOptions , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} , argsDefaultHlsConfig = def + , argsGetHieDbLoc = getHieDbLoc } defaultMain :: Arguments -> IO () @@ -114,7 +116,7 @@ defaultMain Arguments{..} = do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer options argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do + runLanguageServer options argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t