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 * diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index d88225ff5b..5a249f9226 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -7,14 +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 - ,argsDisableKick :: Bool ,argsThreads :: Int ,argsVerbose :: Bool ,argsCommand :: Command @@ -29,14 +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") - <*> 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..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 (unless, 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) @@ -19,20 +19,16 @@ 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 Development.IDE.Graph (ShakeOptions (shakeThreads)) 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)) 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) @@ -68,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 $ @@ -78,32 +72,12 @@ 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 { 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/ghcide.cabal b/ghcide/ghcide.cabal index 216fb1f5f0..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 @@ -348,6 +349,7 @@ test-suite ghcide-tests hls-plugin-api, network-uri, lens, + lsp, lsp-test == 0.14.0.0, optparse-applicative, process, @@ -359,6 +361,7 @@ test-suite ghcide-tests safe-exceptions, shake, hls-graph, + sqlite-simple, tasty, tasty-expected-failure, tasty-hunit, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3c776cb36b..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) @@ -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 @@ -152,8 +152,8 @@ setInitialDynFlags 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) @@ -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/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 9fcc520db2..807fdc77e0 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -134,15 +134,17 @@ 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 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 + _ <- 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 c3a34415cc..b9e731dd0d 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 @@ -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 @@ -295,13 +295,13 @@ 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 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 = 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 94529222ed..77d991ad72 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,9 +36,11 @@ 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) +import Development.IDE.Plugin.LspLogger import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common import Development.IDE.Test (Cursor, @@ -55,6 +57,7 @@ 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.IDE.Types.Options import Development.Shake (getDirectoryFilesIO) import qualified Experiments as Bench import Ide.Plugin.Config @@ -100,7 +103,10 @@ 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 import Text.Regex.TDFA ((=~)) waitForProgressBegin :: Session () @@ -189,7 +195,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 @@ -706,7 +712,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 @@ -4950,7 +4957,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 @@ -4958,8 +4965,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' 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 @@ -5243,36 +5250,24 @@ 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 - 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" - - 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 projDir args s + +getConfigFromEnv ::IO SessionConfig getConfigFromEnv = do logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" @@ -5368,7 +5363,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,18 +5371,47 @@ 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 - let server = IDE.defaultMain arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } + (logger, loggerPlugin) <- lspLogger + server <- async $ IDE.defaultMain arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + , IDE.argsHlsPlugins = + pluginDescToIdePlugins + [ loggerPlugin, Test.blockCommandDescriptor "block-command" ] + <> IDE.argsHlsPlugins arguments + , 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}} + , IDE.argsLogger = pure logger + } - withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps "." 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 + + 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)" + + hClose hInWrite + hClose hOutRead + return res positionMappingTests :: TestTree positionMappingTests = 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) + -- ---------------------------------------------------------------------