From d8509b7c2b5ad4088e77811c43aa388972a24691 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 14:24:20 +0100 Subject: [PATCH 01/13] rethrow language server exceptions in the main thread --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 9fcc520db2..0f33eaf3dc 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -141,6 +141,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan logError (ideLogger ide) $ T.pack $ "Fatal error in server thread: " <> show e exitClientMsg + throwIO e handleServerException _ = pure () _ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) From 0a2957722a9d9b6261cf32e6e29bb5891cc02401 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 14:51:43 +0100 Subject: [PATCH 02/13] Make testIde more like Test.Hls.runSessionWithServer' --- ghcide/test/exe/Main.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 94529222ed..0b30959e6d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5381,13 +5381,23 @@ testIde arguments session = do config <- getConfigFromEnv (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe - let server = IDE.defaultMain arguments + server <- async $ IDE.defaultMain arguments { IDE.argsHandleIn = pure hInRead , IDE.argsHandleOut = pure hOutWrite + , IDE.argsIdeOptions = \config sessionLoader -> + let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True} + in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}} } - withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session + runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session + + hClose inw + timeout 3 (wait server) >>= \case + Just () -> pure () + Nothing -> do + putStrLn "Server does not exit in 3s, canceling the async task..." + (t, _) <- duration $ cancel server + putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" positionMappingTests :: TestTree positionMappingTests = From bd36fe09037474242fa2bad267a37b9ea355802c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 16:25:09 +0100 Subject: [PATCH 03/13] Run server in-process for tests This is so that we can catch SQLError for retrying --- ghcide/exe/Arguments.hs | 2 -- ghcide/exe/Main.hs | 26 ++--------------- ghcide/test/exe/Main.hs | 64 ++++++++++++++++++++++++----------------- 3 files changed, 39 insertions(+), 53 deletions(-) diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index d88225ff5b..914073b900 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -14,7 +14,6 @@ data Arguments = Arguments ,argsShakeProfiling :: Maybe FilePath ,argsOTMemoryProfiling :: Bool ,argsTesting :: Bool - ,argsDisableKick :: Bool ,argsThreads :: Int ,argsVerbose :: Bool ,argsCommand :: Command @@ -36,7 +35,6 @@ arguments = Arguments <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") - <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (long "verbose" <> help "Include internal events in logging output") <*> (commandP <|> lspCommand <|> checkCommand) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 99b6c18d7a..5b3e16291e 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -8,7 +8,7 @@ module Main(main) where import Arguments (Arguments (..), getArguments) import Control.Concurrent.Extra (newLock, withLock) -import Control.Monad.Extra (unless, when, whenJust) +import Control.Monad.Extra (when, whenJust) import qualified Data.Aeson.Encode.Pretty as A import Data.Default (Default (def)) import Data.List.Extra (upper) @@ -19,12 +19,9 @@ import qualified Data.Text.Lazy.IO as LT import Data.Version (showVersion) import Development.GitRev (gitHash) import Development.IDE (Logger (Logger), - Priority (Info), action) -import Development.IDE.Core.OfInterest (kick) -import Development.IDE.Core.Rules (mainRule) + Priority (Info)) import qualified Development.IDE.Main as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Ide.Plugin.Config (Config (checkParents, checkProject)) @@ -78,26 +75,7 @@ main = do Main.defaultMain def {Main.argCommand = argsCommand - ,Main.argsLogger = pure 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 = \config sessionLoader -> let defOptions = defaultIdeOptions sessionLoader in defOptions diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 0b30959e6d..9a7ee1fe57 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -55,7 +55,8 @@ import Development.IDE.Test (Cursor, import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) +import Development.IDE.Types.Options +import Development.Shake (getDirectoryFilesIO, shakeThreads) import qualified Experiments as Bench import Ide.Plugin.Config import Language.LSP.Test @@ -100,7 +101,9 @@ import Ide.Types import Data.String (IsString(fromString)) import qualified Language.LSP.Types as LSP import Data.IORef.Extra (atomicModifyIORef_) +import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import qualified Development.IDE.Plugin.Test as Test import Text.Regex.TDFA ((=~)) waitForProgressBegin :: Session () @@ -706,7 +709,8 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r expectNoMoreDiagnostics 0.5 where -- similar to run except it disables kick - runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s + runTestNoKick s = withTempDir $ \dir -> runInDir' argsNoKick dir "." "." s + argsNoKick = def { IDE.argsRules = mainRule } typeCheck doc = do Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc @@ -4959,7 +4963,7 @@ rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do where -- similar to run' except we can configure where to start ghcide and session runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) + runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' def dir dir1 dir2 (s dir) -- | Test if ghcide asynchronously handles Commands and user Requests asyncTests :: TestTree @@ -5243,15 +5247,14 @@ run' :: (FilePath -> Session a) -> IO a run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a -runInDir dir = runInDir' dir "." "." [] +runInDir dir = runInDir' def dir "." "." withLongTimeout :: IO a -> IO a withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") -- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. -runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a -runInDir' dir startExeIn startSessionIn extraOptions s = do - ghcideExe <- locateGhcideExecutable +runInDir' :: IDE.Arguments -> FilePath -> FilePath -> FilePath -> Session a -> IO a +runInDir' args dir startExeIn startSessionIn s = do let startDir = dir startExeIn let projDir = dir startSessionIn @@ -5260,19 +5263,13 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 -- since the package import test creates "Data/List.hs", which otherwise has no physical home createDirectoryIfMissing True $ projDir ++ "/Data" - - shakeProfiling <- getEnv "SHAKE_PROFILING" - let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir - ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] - ] ++ extraOptions -- HIE calls getXgdDirectory which assumes that HOME is set. -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False - conf <- getConfigFromEnv - runSessionWithConfig conf cmd lspTestCaps projDir s -getConfigFromEnv :: IO SessionConfig + testIde dir args s + +getConfigFromEnv ::IO SessionConfig getConfigFromEnv = do logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" @@ -5368,7 +5365,7 @@ unitTests = do | i <- [(1::Int)..20] ] ++ Ghcide.descriptors - testIde def{IDE.argsHlsPlugins = plugins} $ do + testIde "." def{IDE.argsHlsPlugins = plugins} $ do _ <- createDoc "haskell" "A.hs" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef @@ -5376,22 +5373,33 @@ unitTests = do liftIO $ actualOrder @?= reverse [(1::Int)..20] ] -testIde :: IDE.Arguments -> Session () -> IO () -testIde arguments session = do +testIde :: FilePath -> IDE.Arguments -> Session a -> IO a +testIde rootDir arguments session = do config <- getConfigFromEnv + shakeProfiling <- getEnv "SHAKE_PROFILING" (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe server <- async $ IDE.defaultMain arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - , IDE.argsIdeOptions = \config sessionLoader -> - let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True} - in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}} - } + -- TODO install a logger that logs to the LSP stream, otherwise it's hard to debug test failures + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + , IDE.argsHlsPlugins = + pluginDescToIdePlugins $ + Ghcide.descriptors + ++ [Test.blockCommandDescriptor "block-command" ] + , IDE.argsGhcidePlugin = Test.plugin + , IDE.argsIdeOptions = \config sessionLoader -> + let ideOptions = (IDE.argsIdeOptions def config sessionLoader) + {optTesting = IdeTesting True + ,optShakeProfiling = shakeProfiling + } + in ideOptions + { optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}} + } - runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session + res <- runSessionWithHandles hInWrite hOutRead config lspTestCaps rootDir session - hClose inw + hClose hInWrite timeout 3 (wait server) >>= \case Just () -> pure () Nothing -> do @@ -5399,6 +5407,8 @@ testIde arguments session = do (t, _) <- duration $ cancel server putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" + return res + positionMappingTests :: TestTree positionMappingTests = testGroup "position mapping" From a8ce19af2e2f3ba71df676254242aa71cd89d6dd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 16:35:03 +0100 Subject: [PATCH 04/13] retry ghcide tests on SQLError --- ghcide/ghcide.cabal | 1 + ghcide/test/exe/Main.hs | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 216fb1f5f0..faa1c155d0 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -359,6 +359,7 @@ test-suite ghcide-tests safe-exceptions, shake, hls-graph, + sqlite-simple, tasty, tasty-expected-failure, tasty-hunit, diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9a7ee1fe57..0675878d93 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -101,6 +101,7 @@ import Ide.Types import Data.String (IsString(fromString)) import qualified Language.LSP.Types as LSP import Data.IORef.Extra (atomicModifyIORef_) +import Database.SQLite.Simple (SQLError(SQLError)) import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import qualified Development.IDE.Plugin.Test as Test @@ -5397,7 +5398,11 @@ testIde rootDir arguments session = do { optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}} } - res <- runSessionWithHandles hInWrite hOutRead config lspTestCaps rootDir session + let runIt = runSessionWithHandles hInWrite hOutRead config lspTestCaps rootDir session + -- catch SQL errors and retry once to handle the hiedb getting locked by a previous test + res <- runIt `catch` \SQLError{} -> do + sleep 1 + runIt hClose hInWrite timeout 3 (wait server) >>= \case From 64cc8fc37e072601d51d529ba25d53b9847e39d3 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 17:01:25 +0100 Subject: [PATCH 05/13] add test logger --- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 28 +++++++-------- ghcide/src/Development/IDE/Main.hs | 14 ++++---- ghcide/test/exe/Main.hs | 11 +++--- ghcide/test/src/Development/IDE/Test.hs | 21 +++++++++++ hls-plugin-api/src/Ide/Types.hs | 36 ++++++++++--------- 6 files changed, 69 insertions(+), 42 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index faa1c155d0..3b705920bc 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -348,6 +348,7 @@ test-suite ghcide-tests hls-plugin-api, network-uri, lens, + lsp, lsp-test == 0.14.0.0, optparse-applicative, process, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3c776cb36b..65f408ad73 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -85,12 +85,12 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue import qualified Data.HashSet as Set import Database.SQLite.Simple +import GHC.LanguageExtensions (Extension (EmptyCase)) import HIE.Bios.Cradle (yamlConfig) import HieDb.Create import HieDb.Types import HieDb.Utils import Maybes (MaybeT (runMaybeT)) -import GHC.LanguageExtensions (Extension(EmptyCase)) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -107,7 +107,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 :: Logger -> IO (Maybe LibDir) , fakeUid :: InstalledUnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, @@ -124,26 +124,26 @@ instance Default SessionLoadingOptions where ,fakeUid = toInstalledUnitId (stringToUnitId "main") } -getInitialGhcLibDirDefault :: IO (Maybe LibDir) -getInitialGhcLibDirDefault = do +getInitialGhcLibDirDefault :: Logger -> IO (Maybe LibDir) +getInitialGhcLibDirDefault logger = do dir <- IO.getCurrentDirectory hieYaml <- runMaybeT $ yamlConfig dir cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml - hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle + logDebug logger $ "setInitialDynFlags cradle: " <> T.pack(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) + logError logger $ "Couldn't load cradle for libdir: " <> T.pack(show (err,dir,hieYaml,cradle)) pure Nothing CradleNone -> do - hPutStrLn stderr "Couldn't load cradle (CradleNone)" + logError logger "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 :: Logger -> SessionLoadingOptions -> IO (Maybe LibDir) +setInitialDynFlags logger SessionLoadingOptions{..} = do + libdir <- getInitialGhcLibDir logger dynFlags <- mapM dynFlagsForPrinting libdir mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir @@ -409,7 +409,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfp <> ")" eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ - cradleToOptsAndLibDir cradle cfp + cradleToOptsAndLibDir logger cradle cfp logDebug logger $ T.pack ("Session loading result: " <> show eopts) case eopts of @@ -479,12 +479,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory -cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath +cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) -cradleToOptsAndLibDir cradle file = do +cradleToOptsAndLibDir logger cradle file = do -- Start off by getting the session options let showLine s = hPutStrLn stderr ("> " ++ s) - hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle + logDebug logger $ "Output from setting up the cradle " <> T.pack (show cradle) cradleRes <- runCradle (cradleOptsProg cradle) showLine file case cradleRes of CradleSuccess r -> do diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index c3a34415cc..72c7df56a1 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -56,7 +56,7 @@ import Development.IDE.Session (SessionLoadingOptions, setInitialDynFlags) import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger (Logger)) +import Development.IDE.Types.Logger import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress), clientSupportsProgress, @@ -198,11 +198,11 @@ defaultMain Arguments{..} = do case argCommand of LSP -> do t <- offsetTime - hPutStrLn stderr "Starting LSP server..." - hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" + logInfo logger "Starting LSP server..." + logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do t <- t - hPutStrLn stderr $ "Started LSP server in " ++ showDuration t + logInfo logger $ "Started LSP server in " <> T.pack(showDuration t) dir <- IO.getCurrentDirectory @@ -211,8 +211,8 @@ defaultMain Arguments{..} = do -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath') -- before calling this function _mlibdir <- - setInitialDynFlags argsSessionLoadingOptions - `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) + setInitialDynFlags logger argsSessionLoadingOptions + `catchAny` (\e -> (logError logger $ "setInitialDynFlags: " <> T.pack(displayException e)) >> pure Nothing) sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath config <- LSP.runLspT env LSP.getConfig @@ -295,7 +295,7 @@ defaultMain Arguments{..} = do Db dir opts cmd -> do dbLoc <- getHieDbLoc dir hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags def + mlibdir <- setInitialDynFlags logger def case mlibdir of Nothing -> exitWith $ ExitFailure 1 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 0675878d93..4fee17f02b 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -51,7 +51,7 @@ import Development.IDE.Test (Cursor, expectNoMoreDiagnostics, flushMessages, standardizeQuotes, - waitForAction) + waitForAction, lspLogger) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -5380,14 +5380,14 @@ testIde rootDir arguments session = do shakeProfiling <- getEnv "SHAKE_PROFILING" (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe + (logger, loggerPlugin) <- lspLogger server <- async $ IDE.defaultMain arguments - -- TODO install a logger that logs to the LSP stream, otherwise it's hard to debug test failures { IDE.argsHandleIn = pure hInRead , IDE.argsHandleOut = pure hOutWrite , IDE.argsHlsPlugins = - pluginDescToIdePlugins $ - Ghcide.descriptors - ++ [Test.blockCommandDescriptor "block-command" ] + pluginDescToIdePlugins + [ loggerPlugin, Test.blockCommandDescriptor "block-command" ] + <> IDE.argsHlsPlugins arguments , IDE.argsGhcidePlugin = Test.plugin , IDE.argsIdeOptions = \config sessionLoader -> let ideOptions = (IDE.argsIdeOptions def config sessionLoader) @@ -5396,6 +5396,7 @@ testIde rootDir arguments session = do } in ideOptions { optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}} + , IDE.argsLogger = pure logger } let runIt = runSessionWithHandles hInWrite hOutRead config lspTestCaps rootDir session diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 420fb6736c..0bd2d3f347 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -20,19 +20,25 @@ module Development.IDE.Test , standardizeQuotes , flushMessages , waitForAction + , lspLogger ) where import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad +import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class import qualified Data.Aeson as A import Data.Bifunctor (second) +import Data.IORef import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult) +import Development.IDE.Types.Logger +import Ide.Types +import qualified Language.LSP.Server as LSP import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types @@ -200,3 +206,18 @@ waitForAction key TextDocumentIdentifier{_uri} = do case A.fromJSON e of A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing A.Success a -> pure a + +-- lspLogger :: lspEnv a -> T.Text -> IO () +lspLogger :: IO (Logger, PluginDescriptor a) +lspLogger = do + lspEnvRef <- newIORef Nothing + let plugin = (defaultPluginDescriptor "lspLogging"){ + pluginNotificationHandlers = + mkPluginNotificationHandler SInitialized $ \_ _ _ -> + liftIO $ readIORef lspEnvRef >>= writeIORef lspEnvRef + } + logger = Logger $ \_p msg -> do + env <- readIORef lspEnvRef + whenJust env $ \env -> + LSP.runLspT env (LSP.sendNotification (SCustomMethod "ghcide/log") (A.String msg)) + return (logger, plugin) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c17171b2f0..713a1487dd 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Ide.Types where @@ -55,6 +57,8 @@ import Text.Regex.TDFA.Text () newtype IdePlugins ideState = IdePlugins { ipMap :: [(PluginId, PluginDescriptor ideState)]} + deriving newtype (Monoid, Semigroup) + -- --------------------------------------------------------------------- From de5f5fe38aaaea3fcf059ae26035cb5c17c13eee Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 17:43:54 +0100 Subject: [PATCH 06/13] clean up --- ghcide/test/exe/Main.hs | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 4fee17f02b..cd2746bbd4 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -710,7 +710,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r expectNoMoreDiagnostics 0.5 where -- similar to run except it disables kick - runTestNoKick s = withTempDir $ \dir -> runInDir' argsNoKick dir "." "." s + runTestNoKick s = withTempDir $ \dir -> runInDir' argsNoKick dir "." s argsNoKick = def { IDE.argsRules = mainRule } typeCheck doc = do @@ -4955,7 +4955,7 @@ benchmarkTests = -- | checks if we use InitializeParams.rootUri for loading session rootUriTests :: TestTree -rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do +rootUriTests = testCase "use rootUri" . runTest "dirB" $ \dir -> do let bPath = dir "dirB/Foo.hs" liftIO $ copyTestDataFiles dir "rootUri" bSource <- liftIO $ readFileUtf8 bPath @@ -4963,8 +4963,8 @@ rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do expectNoMoreDiagnostics 0.5 where -- similar to run' except we can configure where to start ghcide and session - runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' def dir dir1 dir2 (s dir) + runTest :: FilePath -> (FilePath -> Session ()) -> IO () + runTest dir2 s = withTempDir $ \dir -> runInDir' def dir dir2 (s dir) -- | Test if ghcide asynchronously handles Commands and user Requests asyncTests :: TestTree @@ -5248,27 +5248,22 @@ run' :: (FilePath -> Session a) -> IO a run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a -runInDir dir = runInDir' def dir "." "." +runInDir dir = runInDir' def dir "." withLongTimeout :: IO a -> IO a withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") -- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. -runInDir' :: IDE.Arguments -> FilePath -> FilePath -> FilePath -> Session a -> IO a -runInDir' args dir startExeIn startSessionIn s = do - let startDir = dir startExeIn +runInDir' :: IDE.Arguments -> FilePath -> FilePath -> Session a -> IO a +runInDir' args dir startSessionIn s = do let projDir = dir startSessionIn - createDirectoryIfMissing True startDir createDirectoryIfMissing True projDir - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ projDir ++ "/Data" -- HIE calls getXgdDirectory which assumes that HOME is set. -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False - testIde dir args s + testIde projDir args s getConfigFromEnv ::IO SessionConfig getConfigFromEnv = do @@ -5405,7 +5400,7 @@ testIde rootDir arguments session = do sleep 1 runIt - hClose hInWrite + -- hClose hInWrite timeout 3 (wait server) >>= \case Just () -> pure () Nothing -> do From 2e195709717c81f94e6a183a4ff79aba90d4fd39 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 17:45:42 +0100 Subject: [PATCH 07/13] fix test --- ghcide/test/exe/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index cd2746bbd4..eaad9b76f5 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -193,7 +193,7 @@ initializeResponseTests = withResource acquire release tests where , chk "NO doc link" _documentLinkProvider Nothing , chk "NO color" _colorProvider (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId] + , che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId] , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) , chk "NO experimental" _experimental Nothing ] where From c4a1c5370a44b04df0641c0604ad637be6c241aa Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 18:01:45 +0100 Subject: [PATCH 08/13] clean up more flags --- ghcide/exe/Arguments.hs | 8 ++------ ghcide/exe/Main.hs | 8 ++------ 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 914073b900..5a249f9226 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -7,13 +7,11 @@ import Development.IDE.Main (Command (..), commandP) import Options.Applicative data Arguments = Arguments - {argsCwd :: Maybe FilePath - ,argsVersion :: Bool + {argsVersion :: Bool ,argsVSCodeExtensionSchema :: Bool ,argsDefaultConfig :: Bool ,argsShakeProfiling :: Maybe FilePath ,argsOTMemoryProfiling :: Bool - ,argsTesting :: Bool ,argsThreads :: Int ,argsVerbose :: Bool ,argsCommand :: Command @@ -28,13 +26,11 @@ getArguments = execParser opts arguments :: Parser Arguments arguments = Arguments - <$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") - <*> switch (long "version" <> help "Show ghcide and GHC versions") + <$> switch (long "version" <> help "Show ghcide and GHC versions") <*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") <*> switch (long "generate-default-config" <> help "Print config supported by the server with default values") <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") - <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (long "verbose" <> help "Include internal events in logging output") <*> (commandP <|> lspCommand <|> checkCommand) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 5b3e16291e..f713893139 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -8,7 +8,7 @@ module Main(main) where import Arguments (Arguments (..), getArguments) import Control.Concurrent.Extra (newLock, withLock) -import Control.Monad.Extra (when, whenJust) +import Control.Monad.Extra (when) import qualified Data.Aeson.Encode.Pretty as A import Data.Default (Default (def)) import Data.List.Extra (upper) @@ -20,16 +20,15 @@ import Data.Version (showVersion) import Development.GitRev (gitHash) import Development.IDE (Logger (Logger), Priority (Info)) +import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Options -import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) -import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) @@ -65,8 +64,6 @@ main = do LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins exitSuccess - whenJust argsCwd IO.setCurrentDirectory - -- lock to avoid overlapping output on stdout lock <- newLock let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $ @@ -81,7 +78,6 @@ main = do in defOptions { optShakeProfiling = argsShakeProfiling , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , optTesting = IdeTesting argsTesting , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} , optCheckParents = pure $ checkParents config , optCheckProject = pure $ checkProject config From c9a4b22d321c49ec04627c0254c446f0f04055e4 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 19:13:27 +0100 Subject: [PATCH 09/13] https://github.com/haskell/lsp/pull/326 --- cabal.project | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/cabal.project b/cabal.project index b82db73bcb..e6164de20a 100644 --- a/cabal.project +++ b/cabal.project @@ -17,6 +17,11 @@ packages: ./plugins/hls-retrie-plugin ./plugins/hls-haddock-comments-plugin ./plugins/hls-splice-plugin +source-repository-package + type: git + location: https://github.com/pepeiborra/lsp + tag: a7ef1f7f888298324ffb2e487a4276653e09a675 + subdir: lsp tests: true package * From a9adef34600678c7cc6b78627d99af651290b18e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 19:24:17 +0100 Subject: [PATCH 10/13] Move lspLogger to the ghcide library --- ghcide/ghcide.cabal | 1 + .../src/Development/IDE/Plugin/LspLogger.hs | 25 +++++++++++++++++++ ghcide/test/exe/Main.hs | 3 ++- ghcide/test/src/Development/IDE/Test.hs | 21 ---------------- 4 files changed, 28 insertions(+), 22 deletions(-) create mode 100644 ghcide/src/Development/IDE/Plugin/LspLogger.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3b705920bc..293e1143de 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -188,6 +188,7 @@ library Development.IDE.Plugin.CodeAction.ExactPrint Development.IDE.Plugin.HLS Development.IDE.Plugin.HLS.GhcIde + Development.IDE.Plugin.LspLogger Development.IDE.Plugin.Test Development.IDE.Plugin.TypeLenses diff --git a/ghcide/src/Development/IDE/Plugin/LspLogger.hs b/ghcide/src/Development/IDE/Plugin/LspLogger.hs new file mode 100644 index 0000000000..0022a44c4d --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/LspLogger.hs @@ -0,0 +1,25 @@ +module Development.IDE.Plugin.LspLogger (lspLogger) where + +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Class +import qualified Data.Aeson as A +import Data.IORef +import Development.IDE.Types.Logger +import Ide.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types + +-- | A logger that sends messages to the LSP client +lspLogger :: IO (Logger, PluginDescriptor a) +lspLogger = do + lspEnvRef <- newIORef Nothing + let plugin = (defaultPluginDescriptor "lspLogging"){ + pluginNotificationHandlers = + mkPluginNotificationHandler SInitialized $ \_ _ _ -> + liftIO $ readIORef lspEnvRef >>= writeIORef lspEnvRef + } + logger = Logger $ \_p msg -> do + env <- readIORef lspEnvRef + whenJust env $ \env -> + LSP.runLspT env (LSP.sendNotification (SCustomMethod "ghcide/log") (A.String msg)) + return (logger, plugin) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index eaad9b76f5..74a6c2a343 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -39,6 +39,7 @@ import Development.IDE.Core.Shake (Q (..)) import qualified Development.IDE.Main as IDE import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types (extendImportCommandId) +import Development.IDE.Plugin.LspLogger import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common import Development.IDE.Test (Cursor, @@ -51,7 +52,7 @@ import Development.IDE.Test (Cursor, expectNoMoreDiagnostics, flushMessages, standardizeQuotes, - waitForAction, lspLogger) + waitForAction) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 0bd2d3f347..420fb6736c 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -20,25 +20,19 @@ module Development.IDE.Test , standardizeQuotes , flushMessages , waitForAction - , lspLogger ) where import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad -import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class import qualified Data.Aeson as A import Data.Bifunctor (second) -import Data.IORef import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult) -import Development.IDE.Types.Logger -import Ide.Types -import qualified Language.LSP.Server as LSP import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types @@ -206,18 +200,3 @@ waitForAction key TextDocumentIdentifier{_uri} = do case A.fromJSON e of A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing A.Success a -> pure a - --- lspLogger :: lspEnv a -> T.Text -> IO () -lspLogger :: IO (Logger, PluginDescriptor a) -lspLogger = do - lspEnvRef <- newIORef Nothing - let plugin = (defaultPluginDescriptor "lspLogging"){ - pluginNotificationHandlers = - mkPluginNotificationHandler SInitialized $ \_ _ _ -> - liftIO $ readIORef lspEnvRef >>= writeIORef lspEnvRef - } - logger = Logger $ \_p msg -> do - env <- readIORef lspEnvRef - whenJust env $ \env -> - LSP.runLspT env (LSP.sendNotification (SCustomMethod "ghcide/log") (A.String msg)) - return (logger, plugin) From 8fe25bca96ce8d2ae8ac077fdf1a7b21e0093a21 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 19 Apr 2021 08:14:32 +0100 Subject: [PATCH 11/13] Fix more putstrln --- ghcide/session-loader/Development/IDE/Session.hs | 14 +++++++------- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 5 +++-- ghcide/src/Development/IDE/Main.hs | 4 ++-- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 65f408ad73..81adda0c84 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -48,6 +48,7 @@ import Development.IDE.GHC.Compat hiding (Target, TargetFile, TargetModule) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Util +import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports @@ -56,7 +57,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.IDE.Graph (Action) import GHC.Check import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) @@ -152,8 +152,8 @@ setInitialDynFlags logger SessionLoadingOptions{..} = do -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO () -runWithDb fp k = do +runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO () +runWithDb logger fp k = do -- Delete the database if it has an incompatible schema version withHieDb fp (const $ pure ()) `catch` \IncompatibleSchemaVersion{} -> removeFile fp @@ -171,9 +171,9 @@ runWithDb fp k = do k <- atomically $ readTQueue chan k db `catch` \e@SQLError{} -> do - hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e + logWarning logger $ "SQLite error in worker, ignoring: " <> T.pack(show e) `catchAny` \e -> do - hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e + logWarning logger $ "Uncaught error in database worker, ignoring: " <> T.pack(show e) getHieDbLoc :: FilePath -> IO FilePath @@ -346,8 +346,8 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do res <- loadDLL hscEnv "libm.so.6" case res of Nothing -> pure () - Just err -> hPutStrLn stderr $ - "Error dynamically loading libm.so.6:\n" <> err + Just err -> logError logger $ + "Error dynamically loading libm.so.6:\n" <> T.pack err -- Make a map from unit-id to DynFlags, this is used when trying to -- resolve imports. (especially PackageImports) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 0f33eaf3dc..807fdc77e0 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -134,7 +134,8 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan let initConfig = parseConfiguration params - logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + l = ideLogger ide + logInfo l $ T.pack $ "Registering ide configuration: " <> show initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do @@ -143,7 +144,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan exitClientMsg throwIO e handleServerException _ = pure () - _ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do + _ <- flip forkFinally handleServerException $ runWithDb l dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) forever $ do msg <- readChan clientMsgChan diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 72c7df56a1..b9e731dd0d 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -233,7 +233,7 @@ defaultMain Arguments{..} = do Check argFiles -> do dir <- IO.getCurrentDirectory dbLoc <- getHieDbLoc dir - runWithDb dbLoc $ \hiedb hieChan -> do + runWithDb logger 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 @@ -301,7 +301,7 @@ defaultMain Arguments{..} = do Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd Custom projectRoot (IdeCommand c) -> do dbLoc <- getHieDbLoc projectRoot - runWithDb dbLoc $ \hiedb hieChan -> do + runWithDb logger dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." let options = From 732ace5d74d0b6b7f6654c03110f9ba0c870994a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 1 May 2021 06:34:45 +0100 Subject: [PATCH 12/13] close streams after testing --- ghcide/test/exe/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 74a6c2a343..185bea147e 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5401,7 +5401,6 @@ testIde rootDir arguments session = do sleep 1 runIt - -- hClose hInWrite timeout 3 (wait server) >>= \case Just () -> pure () Nothing -> do @@ -5409,6 +5408,8 @@ testIde rootDir arguments session = do (t, _) <- duration $ cancel server putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" + hClose hInWrite + hClose hOutRead return res positionMappingTests :: TestTree From 4edb5860b3e21ca88ab1758bff682f61fbf89634 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 1 May 2021 11:02:11 +0100 Subject: [PATCH 13/13] fix build after rebase --- ghcide/test/exe/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 185bea147e..77d991ad72 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,6 +36,7 @@ import Development.IDE.Core.PositionMapping (PositionResult (..), positionResultToMaybe, toCurrent) import Development.IDE.Core.Shake (Q (..)) +import Development.IDE.Graph (shakeThreads) import qualified Development.IDE.Main as IDE import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types (extendImportCommandId) @@ -57,7 +58,7 @@ import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import Development.Shake (getDirectoryFilesIO, shakeThreads) +import Development.Shake (getDirectoryFilesIO) import qualified Experiments as Bench import Ide.Plugin.Config import Language.LSP.Test