From e6595bb83fd37649f894a22e5a82e217d2b79fe5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 13 May 2024 11:07:00 +0800 Subject: [PATCH 01/96] migrate boot test --- ghcide/test/exe/BootTests.hs | 10 +++++----- ghcide/test/exe/Config.hs | 6 +++++- hls-test-utils/src/Test/Hls.hs | 24 ++++++++++++++++++++++-- 3 files changed, 32 insertions(+), 8 deletions(-) diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs index 07615f41d3..0d92dbe136 100644 --- a/ghcide/test/exe/BootTests.hs +++ b/ghcide/test/exe/BootTests.hs @@ -1,6 +1,7 @@ module BootTests (tests) where -import Config (checkDefs, mkR) +import Config (checkDefs, mkR, runInDir, + runWithExtraFiles) import Control.Applicative.Combinators import Control.Monad import Control.Monad.IO.Class (liftIO) @@ -15,16 +16,15 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import System.FilePath +import Test.Hls.FileSystem (toAbsFp) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "boot" [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" + let cPath = dir `toAbsFp` "C.hs" cSource <- liftIO $ readFileUtf8 cPath -- Dirty the cache liftIO $ runInDir dir $ do @@ -51,6 +51,6 @@ tests = testGroup "boot" let floc = mkR 9 0 9 1 checkDefs locs (pure [floc]) , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir "A.hs") "haskell" + _ <- openDoc (dir `toAbsFp` "A.hs") "haskell" expectNoMoreDiagnostics 2 ] diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 540e0b2451..0a7751fc4b 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -13,6 +13,7 @@ module Config( , testWithDummyPluginEmpty' , testWithDummyPluginAndCap' , runWithExtraFiles + , runInDir , testWithExtraFiles -- * utilities for testing definition and hover @@ -36,7 +37,7 @@ import Language.LSP.Protocol.Types (Null (..)) import System.FilePath (()) import Test.Hls import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (FileSystem) +import Test.Hls.FileSystem (FileSystem, fsRoot) testDataDir :: FilePath testDataDir = "ghcide" "test" "data" @@ -80,6 +81,9 @@ runWithExtraFiles dirName action = do testWithExtraFiles :: String -> String -> (FileSystem -> Session ()) -> TestTree testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action +runInDir :: FileSystem -> Session a -> IO a +runInDir fs = runSessionWithServerNoRootLock False dummyPlugin def def def (fsRoot fs) + pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 840ff6829e..152df13033 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -31,6 +31,7 @@ module Test.Hls runSessionWithServerAndCaps, runSessionWithServerInTmpDir, runSessionWithServerAndCapsInTmpDir, + runSessionWithServerNoRootLock, runSessionWithServer', runSessionWithServerInTmpDir', -- continuation version that take a FileSystem @@ -618,7 +619,7 @@ lockForTempDirs = unsafePerformIO newLock -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ -runSessionWithServer' :: +runSessionWithServerNoRootLock :: (Pretty b) => -- | whether we disable the kick action or not Bool -> @@ -632,7 +633,7 @@ runSessionWithServer' :: FilePath -> Session a -> IO a -runSessionWithServer' disableKick pluginsDp conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do +runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = do (inR, inW) <- createPipe (outR, outW) <- createPipe @@ -676,6 +677,25 @@ runSessionWithServer' disableKick pluginsDp conf sconf caps root s = withLock l putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" pure x +-- | Host a server, and run a test session on it +-- Note: cwd will be shifted into @root@ in @Session a@ +runSessionWithServer' :: + (Pretty b) => + -- | whether we disable the kick action or not + Bool -> + -- | Plugin to load on the server. + PluginTestDescriptor b -> + -- | lsp config for the server + Config -> + -- | config for the test session + SessionConfig -> + ClientCapabilities -> + FilePath -> + Session a -> + IO a +runSessionWithServer' disableKick pluginsDp conf sconf caps root s = + withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s + -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case From 542ea2603f361ba43b839fee0779d1d1ac034c2b Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 08:42:24 +0800 Subject: [PATCH 02/96] restrict the cwd to the outermost layer --- exe/Wrapper.hs | 3 +- ghcide/exe/Main.hs | 6 +- .../session-loader/Development/IDE/Session.hs | 4 +- .../src/Development/IDE/LSP/LanguageServer.hs | 8 +- ghcide/src/Development/IDE/Main.hs | 30 +++-- ghcide/test/exe/ExceptionTests.hs | 104 +++++++----------- ghcide/test/exe/Main.hs | 2 +- ghcide/test/exe/UnitTests.hs | 14 ++- hls-test-utils/src/Test/Hls.hs | 4 +- src/Ide/Main.hs | 2 +- 10 files changed, 80 insertions(+), 97 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 6de88abcc0..0309840c97 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -269,7 +269,8 @@ newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a } -- to shut down the LSP. launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO () launchErrorLSP recorder errorMsg = do - let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins []) + cwd <- getCurrentDirectory + let defaultArguments = Main.defaultArguments cwd (cmapWithPrio pretty recorder) (IdePlugins []) inH <- Main.argsHandleIn defaultArguments diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index b3b63fbaf5..959cd8c9d2 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -112,11 +112,11 @@ main = withTelemetryRecorder $ \telemetryRecorder -> do let arguments = if argsTesting - then IDEMain.testing (cmapWithPrio LogIDEMain recorder) hlsPlugins - else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsPlugins + then IDEMain.testing argsCwd (cmapWithPrio LogIDEMain recorder) hlsPlugins + else IDEMain.defaultArguments argsCwd (cmapWithPrio LogIDEMain recorder) hlsPlugins IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDEMain.argsProjectRoot = Just argsCwd + { IDEMain.argsProjectRoot = argsCwd , IDEMain.argCommand = argsCommand , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin] diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 71688afd1d..2f85053111 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -632,7 +632,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do - lfpLog <- flip makeRelative cfp <$> getCurrentDirectory + let lfpLog = makeRelative dir cfp logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $ @@ -640,7 +640,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do cradle <- loadCradle recorder hieYaml dir -- TODO: Why are we repeating the same command we have on line 646? - lfp <- flip makeRelative cfp <$> getCurrentDirectory + let lfp = makeRelative dir cfp when optTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 76893c38a0..e1b5c664d9 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -128,7 +128,7 @@ setupLSP :: Recorder (WithPriority Log) -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), @@ -186,7 +186,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do handleInit :: Recorder (WithPriority Log) -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () -> IO () -> (SomeLspId -> IO ()) @@ -196,7 +196,7 @@ handleInit handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let root = LSP.resRootPath env - dir <- maybe getCurrentDirectory return root + dir <- maybe (error "No root directory") pure root dbLoc <- getHieDbLoc dir let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig @@ -240,7 +240,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa logWith recorder Info LogReactorThreadStopped (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb hieChan + ide <- getIdeState env dir withHieDb hieChan registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b4aa72f5fa..f7edf46778 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -208,7 +208,7 @@ commandP plugins = data Arguments = Arguments - { argsProjectRoot :: Maybe FilePath + { argsProjectRoot :: FilePath , argCommand :: Command , argsRules :: Rules () , argsHlsPlugins :: IdePlugins IdeState @@ -226,9 +226,9 @@ data Arguments = Arguments , argsDisableKick :: Bool -- ^ flag to disable kick used for testing } -defaultArguments :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -defaultArguments recorder plugins = Arguments - { argsProjectRoot = Nothing +defaultArguments :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments +defaultArguments fp recorder plugins = Arguments + { argsProjectRoot = fp , argCommand = LSP , argsRules = mainRule (cmapWithPrio LogRules recorder) def , argsGhcidePlugin = mempty @@ -263,11 +263,11 @@ defaultArguments recorder plugins = Arguments } -testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -testing recorder plugins = +testing :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments +testing fp recorder plugins = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = - defaultArguments recorder plugins + defaultArguments fp recorder plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -316,22 +316,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState + let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState getIdeState env rootPath withHieDb hieChan = do - traverse_ IO.setCurrentDirectory rootPath t <- ioT logWith recorder Info $ LogLspStartDuration t - - dir <- maybe IO.getCurrentDirectory return rootPath - -- We want to set the global DynFlags right now, so that we can use -- `unsafeGlobalDynFlags` even before the project is configured _mlibdir <- - setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions + setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -378,7 +374,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats Check argFiles -> do - dir <- maybe IO.getCurrentDirectory return argsProjectRoot + let dir = argsProjectRoot dbLoc <- getHieDbLoc dir runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error @@ -426,7 +422,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re unless (null failed) (exitWith $ ExitFailure (length failed)) Db opts cmd -> do - root <- maybe IO.getCurrentDirectory return argsProjectRoot + let root = argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def @@ -436,7 +432,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) Custom (IdeCommand c) -> do - root <- maybe IO.getCurrentDirectory return argsProjectRoot + let root = argsProjectRoot dbLoc <- getHieDbLoc root runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 6d19891978..247ce14c93 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -1,48 +1,45 @@ module ExceptionTests (tests) where -import Control.Exception (ArithException (DivideByZero), - throwIO) +import Config +import Control.Exception (ArithException (DivideByZero), + throwIO) import Control.Lens -import Control.Monad.Error.Class (MonadError (throwError)) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as A -import Data.Text as T -import Development.IDE.Core.Shake (IdeState (..)) -import qualified Development.IDE.LSP.Notifications as Notifications -import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.HLS (toResponseError) -import Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Options -import GHC.Base (coerce) -import Ide.Logger (Recorder, WithPriority, - cmapWithPrio) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Default (Default (..)) +import Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) +import Development.IDE.Plugin.HLS (toResponseError) +import GHC.Base (coerce) +import Ide.Logger (Recorder, WithPriority) import Ide.Plugin.Error -import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) -import Ide.PluginUtils (idePluginsToPluginDesc, - pluginDescToIdePlugins) +import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) +import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types -import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), - mkRange) +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) import Language.LSP.Test -import LogType (Log (..)) -import Test.Hls (waitForProgressDone) +import LogType (Log (..)) +import Test.Hls (runSessionWithServerInTmpDir, + waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit -import TestUtils -tests :: Recorder (WithPriority Log) -> TestTree -tests recorder = do +tests :: TestTree +tests = do testGroup "Exceptions and PluginError" [ testGroup "Testing that IO Exceptions are caught in..." [ testCase "PluginHandlers" $ do let pluginId = "plugin-handler-exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins _ = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do @@ -50,7 +47,7 @@ tests recorder = do pure (InL []) ] }] - testIde recorder (testingLite recorder plugins) $ do + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -63,7 +60,8 @@ tests recorder = do , testCase "Commands" $ do let pluginId = "command-exception" commandId = CommandId "exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins _ = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginCommands = [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do @@ -71,7 +69,7 @@ tests recorder = do pure (InR Null) ] }] - testIde recorder (testingLite recorder plugins) $ do + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -85,7 +83,8 @@ tests recorder = do , testCase "Notification Handlers" $ do let pluginId = "notification-exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins _ = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -96,7 +95,7 @@ tests recorder = do pure (InL []) ] }] - testIde recorder (testingLite recorder plugins) $ do + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -108,37 +107,18 @@ tests recorder = do _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] , testGroup "Testing PluginError order..." - [ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") - , pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") - , pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) + [ pluginOrderTestCase "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") + , pluginOrderTestCase "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") + , pluginOrderTestCase "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) ] ] -testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments -testingLite recorder plugins = - let - arguments@IDE.Arguments{ argsIdeOptions } = - IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins - hlsPlugins = pluginDescToIdePlugins $ - idePluginsToPluginDesc plugins - ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ideOptions config sessionLoader = - let - defOptions = argsIdeOptions config sessionLoader - in - defOptions{ optTesting = IdeTesting True } - in - arguments - { IDE.argsHlsPlugins = hlsPlugins - , IDE.argsIdeOptions = ideOptions - } - -pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree -pluginOrderTestCase recorder msg err1 err2 = +pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree +pluginOrderTestCase msg err1 err2 = testCase msg $ do let pluginId = "error-order-test" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins _ = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do @@ -147,7 +127,7 @@ pluginOrderTestCase recorder msg err1 err2 = throwError err2 ] }] - testIde recorder (testingLite recorder plugins) $ do + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8c6f876f39..558115fc24 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -114,5 +114,5 @@ main = do , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests - , ExceptionTests.tests recorder + , ExceptionTests.tests ] diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index 4900b7cae4..a6ba0abd01 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -1,6 +1,7 @@ module UnitTests (tests) where +import Config (mkIdeTestFs) import Control.Concurrent import Control.Monad.IO.Class (liftIO) import Data.IORef @@ -30,7 +31,9 @@ import Network.URI import qualified Progress import System.IO.Extra hiding (withTempDir) import System.Mem (performGC) -import Test.Hls (waitForProgressDone) +import Test.Hls (IdeState, def, + runSessionWithServerInTmpDir, + waitForProgressDone) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -72,7 +75,9 @@ tests recorder = do expected `isInfixOf` shown , testCase "notification handlers run in priority order" $ do orderRef <- newIORef [] - let plugins = pluginDescToIdePlugins $ + let + plugins ::Recorder (WithPriority Ghcide.Log) -> IdePlugins IdeState + plugins recorder = pluginDescToIdePlugins $ [ (priorityPluginDescriptor i) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -80,10 +85,11 @@ tests recorder = do ] } | i <- [1..20] - ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) + ] ++ Ghcide.descriptors recorder priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do + -- testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone actualOrder <- liftIO $ reverse <$> readIORef orderRef diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 152df13033..7c0030192d 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -647,7 +647,7 @@ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = d hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins arguments@Arguments{ argsIdeOptions } = - testing (cmapWithPrio LogIDEMain recorderIde) hlsPlugins + testing root (cmapWithPrio LogIDEMain recorderIde) hlsPlugins ideOptions config ghcSession = let defIdeOptions = argsIdeOptions config ghcSession @@ -663,7 +663,7 @@ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = d , argsHandleOut = pure outW , argsDefaultHlsConfig = conf , argsIdeOptions = ideOptions - , argsProjectRoot = Just root + , argsProjectRoot = root , argsDisableKick = disableKick } diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 457e0dc4ec..30ff1a90a4 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -130,7 +130,7 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryRec when (isLSP argsCommand) $ do log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) - let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) + let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) dir (cmapWithPrio LogIDEMain recorder) idePlugins let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty From f7611a286207572253c4f5e3d59565fbfca8e493 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 10:09:37 +0800 Subject: [PATCH 03/96] remove makeAbsolute --- .../session-loader/Development/IDE/Session.hs | 39 +++++++++++-------- ghcide/src/Development/IDE/Core/Rules.hs | 8 ++-- ghcide/src/Development/IDE/Core/Service.hs | 8 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 4 +- ghcide/src/Development/IDE/Main.hs | 5 ++- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 11 ++++-- .../src/Ide/Plugin/ModuleName.hs | 7 +++- .../src/Ide/Plugin/Retrie.hs | 8 +++- 8 files changed, 55 insertions(+), 35 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2f85053111..801a1b87c7 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -437,8 +437,13 @@ getHieDbLoc dir = do loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute dir file + | isAbsolute file = file + | otherwise = dir file loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do + let toAbsolutePath = toAbsolute dir cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) @@ -459,7 +464,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path -- try and normalise that -- e.g. see https://github.com/haskell/ghcide/issues/126 - res' <- traverse makeAbsolute res + let res' = toAbsolutePath <$> res return $ normalise <$> res' dummyAs <- async $ return (error "Uninitialised") @@ -521,7 +526,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) + newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) dir let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -588,7 +593,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- HscEnv but set the active component accordingly hscEnv <- emptyHscEnv ideNc _libDir let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv - all_target_details <- new_cache old_deps new_deps + all_target_details <- new_cache old_deps new_deps dir this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) @@ -713,7 +718,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do modifyVar_ hscEnvs (const (return Map.empty)) v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags - cfp <- makeAbsolute file + let cfp = toAbsolutePath file case HM.lookup (toNormalizedFilePath' cfp) v of Just (opts, old_di) -> do deps_ok <- checkDependencyInfo old_di @@ -735,7 +740,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- before attempting to do so. let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) getOptions file = do - ncfp <- toNormalizedFilePath' <$> makeAbsolute file + let ncfp = toNormalizedFilePath' (toAbsolutePath file) cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> @@ -747,7 +752,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do void $ wait as asyncRes <- async $ getOptions file return (asyncRes, wait asyncRes) - pure opts + pure $ (fmap . fmap) toAbsolutePath opts -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -814,19 +819,20 @@ fromTargetId :: [FilePath] -- ^ import paths -> TargetId -> IdeResult HscEnvEq -> DependencyInfo + -> FilePath -> IO [TargetDetails] -- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule modName) env dep = do +fromTargetId is exts (GHC.TargetModule modName) env dep dir = do let fps = [i moduleNameSlashes modName -<.> ext <> boot | ext <- exts , i <- is , boot <- ["", "-boot"] ] - locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps + let locs = fmap (toNormalizedFilePath' . toAbsolute dir) fps return [TargetDetails (TargetModule modName) env dep locs] -- For a 'TargetFile' we consider all the possible module names -fromTargetId _ _ (GHC.TargetFile f _) env deps = do - nf <- toNormalizedFilePath' <$> makeAbsolute f +fromTargetId _ _ (GHC.TargetFile f _) env deps dir = do + let nf = toNormalizedFilePath' $ toAbsolute dir f let other | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") @@ -915,8 +921,9 @@ newComponentCache -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components + -> FilePath -- ^ root dir -> IO [ [TargetDetails] ] -newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do +newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, -- prefer the new one over the old. @@ -961,7 +968,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do forM (Map.elems cis) $ \ci -> do let df = componentDynFlags ci - let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath + let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths (newHscEnvEq dir) cradlePath thisEnv <- do #if MIN_VERSION_ghc(9,3,0) -- In GHC 9.4 we have multi component support, and we have initialised all the units @@ -986,7 +993,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) evaluate $ liftRnf rwhnf $ componentTargets ci - let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends dir ctargets <- concatMapM mk (componentTargets ci) return (L.nubOrdOn targetTarget ctargets) @@ -1171,8 +1178,8 @@ addUnit unit_str = liftEwM $ do putCmdLineState (unit_str : units) -- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do +setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> FilePath -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions cfp (ComponentOptions theOpts compRoot _) dflags dir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1195,7 +1202,7 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do -- -- If we don't end up with a target for the current file in the end, then -- we will report it as an error for that file - abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp) + let abs_fp = toAbsolute dir (fromNormalizedFilePath cfp) let special_target = Compat.mkSimpleTarget df abs_fp pure $ (df, special_target : targets) :| [] where diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 609736fc72..55094bca47 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -159,8 +159,7 @@ import Language.LSP.Server (LspT) import qualified Language.LSP.Server as LSP import Language.LSP.VFS import Prelude hiding (mod) -import System.Directory (doesFileExist, - makeAbsolute) +import System.Directory (doesFileExist) import System.Info.Extra (isWindows) @@ -719,8 +718,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do -- add the deps to the Shake graph let addDependency fp = do -- VSCode uses absolute paths in its filewatch notifications - afp <- liftIO $ makeAbsolute fp - let nfp = toNormalizedFilePath' afp + let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp when itExists $ void $ do use_ GetModificationTime nfp @@ -848,7 +846,7 @@ getModIfaceFromDiskAndIndexRule recorder = hie_loc = Compat.ml_hie_file $ ms_location ms fileHash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) - hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow + let hie_loc' = HieDb.hieModuleHieFile <$> mrow case mrow of Just row | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdb5ba72cb..f59d0b4afa 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -67,8 +67,9 @@ initialise :: Recorder (WithPriority Log) -> WithHieDb -> IndexQueue -> Monitoring + -> FilePath -> IO IdeState -initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do +initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics rootDir = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -86,11 +87,12 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with hiedbChan (optShakeOptions options) metrics - $ do + (do addIdeGlobal $ GlobalIdeOptions options ofInterestRules (cmapWithPrio LogOfInterest recorder) fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv - mainRule + mainRule) + rootDir -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5325b14e7e..5dab889f38 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -535,6 +535,7 @@ data IdeState = IdeState ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopMonitoring :: IO () + ,rootDir :: FilePath } @@ -623,11 +624,12 @@ shakeOpen :: Recorder (WithPriority Log) -> ShakeOptions -> Monitoring -> Rules () + -> FilePath -> IO IdeState shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules = mdo + withHieDb indexQueue opts monitoring rules rootDir = mdo #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index f7edf46778..8dd62c3f14 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -353,6 +353,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re withHieDb hieChan monitoring + rootPath putMVar ideStateVar ide pure ide @@ -404,7 +405,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty dir shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -442,7 +443,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty root shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 502c265077..d6760071f4 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -29,7 +29,6 @@ import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) import OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) import System.FilePath -- | An 'HscEnv' with equality. Two values are considered equal @@ -58,15 +57,19 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv } update <$> Unique.newUnique +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute root path + | isAbsolute path = path + | otherwise = root path -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do +newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq root cradlePath hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 -- Make Absolute since targets are also absolute importPathsCanon <- - mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + mapM (return . toAbsolute root) $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 1192870b00..b8d7f6c35b 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -58,7 +58,6 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS (virtualFileText) -import System.Directory (makeAbsolute) import System.FilePath (dropExtension, normalise, pathSeparator, splitDirectories, @@ -133,6 +132,10 @@ action recorder state uri = do in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code] _ -> pure [] +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute root path + | isAbsolute path = path + | otherwise = root path -- | Possible module names, as derived by the position of the module in the -- source directories. There may be more than one possible name, if the source -- directories are nested inside each other. @@ -150,7 +153,7 @@ pathModuleNames recorder state normFilePath filePath let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) - mdlPath <- liftIO $ makeAbsolute filePath + mdlPath <- liftIO $ (toAbsolute $ rootDir state) filePath logWith recorder Debug (AbsoluteFilePath mdlPath) let suffixes = mapMaybe (`stripPrefix` mdlPath) paths diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 48d2886ff0..8343cdff98 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -129,7 +129,6 @@ import Retrie.SYB (everything, extQ, listify, mkQ) import Retrie.Types import Retrie.Universe (Universe) -import System.Directory (makeAbsolute) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual @@ -760,9 +759,14 @@ reuseParsedModule state f = do (fixities, pm') <- fixFixities state f (fixAnns pm) return (fixities, pm') +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute dir file + | isAbsolute file = file + | otherwise = dir file + getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do - nt <- toNormalizedFilePath' <$> makeAbsolute t + nt <- toNormalizedFilePath' <$> (toAbsolute $ rootDir state) t let getParsedModule f contents = do modSummary <- msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt From 67438ef6aa23ad404af2f142e52dce78b617f95c Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 10:29:15 +0800 Subject: [PATCH 04/96] fix import --- ghcide/src/Development/IDE.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- haskell-language-server.cabal | 1 + .../src/Ide/Plugin/ModuleName.hs | 11 ++++++----- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 3 ++- 5 files changed, 11 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 15cee28f04..547ac9a115 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -31,7 +31,7 @@ import Development.IDE.Core.Shake as X (FastResult (..), defineNoDiagnostics, getClientConfig, getPluginConfigAction, - ideLogger, + ideLogger, rootDir, runIdeAction, shakeExtras, use, useNoFile, diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5dab889f38..aaa2294852 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -22,7 +22,7 @@ -- always stored as real Haskell values, whereas Shake serialises all 'A' values -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake( - IdeState, shakeSessionInit, shakeExtras, shakeDb, + IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets, Target(..), toKnownFiles, IdeRule, IdeResult, diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5f673caafe..67ec32bc97 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -654,6 +654,7 @@ library hls-retrie-plugin , text , transformers , unordered-containers + , filepath default-extensions: DataKinds diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index b8d7f6c35b..f4df5adb9c 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -41,8 +41,8 @@ import Development.IDE (GetParsedModule (GetParse hscEnvWithImportPaths, logWith, realSrcSpanToRange, - runAction, useWithStale, - (<+>)) + rootDir, runAction, + useWithStale, (<+>)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.GHC.Compat (GenLocated (L), @@ -58,10 +58,11 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS (virtualFileText) -import System.FilePath (dropExtension, normalise, +import System.FilePath (dropExtension, + isAbsolute, normalise, pathSeparator, splitDirectories, - takeFileName) + takeFileName, ()) -- |Plugin descriptor descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -153,7 +154,7 @@ pathModuleNames recorder state normFilePath filePath let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) - mdlPath <- liftIO $ (toAbsolute $ rootDir state) filePath + let mdlPath = (toAbsolute $ rootDir state) filePath logWith recorder Debug (AbsoluteFilePath mdlPath) let suffixes = mapMaybe (`stripPrefix` mdlPath) paths diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 8343cdff98..e5eff62b15 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -129,6 +129,7 @@ import Retrie.SYB (everything, extQ, listify, mkQ) import Retrie.Types import Retrie.Universe (Universe) +import System.FilePath (isAbsolute, ()) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual @@ -766,7 +767,7 @@ toAbsolute dir file getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do - nt <- toNormalizedFilePath' <$> (toAbsolute $ rootDir state) t + let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t let getParsedModule f contents = do modSummary <- msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt From 9238ff63c381fb55a939f1e4446cc2b64499a3b8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 11:00:43 +0800 Subject: [PATCH 05/96] fix more dir --- ghcide/session-loader/Development/IDE/Session.hs | 14 +++++++------- ghcide/test/exe/DependentFileTest.hs | 3 ++- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 801a1b87c7..79334e72d3 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -442,8 +442,8 @@ toAbsolute dir file | isAbsolute file = file | otherwise = dir file loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do - let toAbsolutePath = toAbsolute dir +loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do + let toAbsolutePath = toAbsolute rootDir cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) @@ -526,7 +526,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) dir + newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -593,7 +593,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- HscEnv but set the active component accordingly hscEnv <- emptyHscEnv ideNc _libDir let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv - all_target_details <- new_cache old_deps new_deps dir + all_target_details <- new_cache old_deps new_deps rootDir this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) @@ -637,15 +637,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do - let lfpLog = makeRelative dir cfp + let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml dir + cradle <- loadCradle recorder hieYaml rootDir -- TODO: Why are we repeating the same command we have on line 646? - let lfp = makeRelative dir cfp + let lfp = makeRelative rootDir cfp when optTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index dc55ff80d3..56ea3ec22e 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -15,6 +15,7 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import System.Directory (setCurrentDirectory) import Test.Hls.FileSystem (FileSystem, toAbsFp) import Test.Tasty @@ -47,7 +48,7 @@ tests = testGroup "addDependentFile" -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams - [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] + [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ] -- Modifying Baz will now trigger Foo to be rebuilt as well let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial From 8c709abe633aac666bc8018cf855f3d7d3a94d86 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 11:18:18 +0800 Subject: [PATCH 06/96] use abs path in template haskell --- ghcide/test/exe/DependentFileTest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index 56ea3ec22e..f417a13bbd 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -36,8 +36,8 @@ tests = testGroup "addDependentFile" , "import Language.Haskell.TH.Syntax" , "foo :: Int" , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" + , " qAddDependentFile \"" <> T.pack depFilePath <> "\"" + , " f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")" , " if f == \"B\" then [| 1 |] else lift f)" ] let bazContent = T.unlines ["module Baz where", "import Foo ()"] From 5b15ebfa897cf7034a653379944e04a151f49806 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 11:51:28 +0800 Subject: [PATCH 07/96] fix reference test --- ghcide/test/exe/ReferenceTests.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 3bafb0b20d..cf8576d12b 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -27,6 +27,7 @@ import Data.Default (def) import Data.Tuple.Extra import GHC.TypeLits (symbolVal) import Ide.Types +import System.FilePath (isAbsolute, ()) import Test.Hls (FromServerMessage' (..), SMethod (..), TCustomMessage (..), @@ -167,9 +168,10 @@ getReferences' (file, l, c) includeDeclaration = do -referenceTestSession :: String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree referenceTestSession name thisDoc docs' f = do testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do + let rootDir = toAbsFp fs "" -- needed to build whole project indexing configureCheckProject True -- need to get the real paths through links @@ -187,23 +189,28 @@ referenceTestSession name thisDoc docs' f = do doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) loop (delete doc docs) loop docs - f + f rootDir closeDoc docid -- | Given a location, lookup the symbol and all references to it. Make sure -- they are the ones we expect. referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ do + referenceTestSession name (fst3 loc) docs $ \rootDir -> do actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` expected + liftIO $ expectSameLocations rootDir actual expected where docs = map fst3 expected type SymbolLocation = (FilePath, UInt, UInt) -expectSameLocations :: (HasCallStack) => [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute root path + | isAbsolute path = path + | otherwise = root path + +expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion +expectSameLocations rootDir actual expected = do let actual' = Set.map (\location -> (location ^. L.uri , location ^. L.range . L.start . L.line . Lens.to fromIntegral @@ -211,7 +218,7 @@ expectSameLocations actual expected = do $ Set.fromList actual expected' <- Set.fromList <$> (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file + fp <- canonicalizePath $ toAbsolute rootDir file return (filePathToUri fp, l, c)) actual' @?= expected' From 2eae58ba02ba3218d837bfb80743e7f5ef5c0801 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 12:28:43 +0800 Subject: [PATCH 08/96] fix ExceptionTests --- ghcide/test/exe/ExceptionTests.hs | 51 ++++++++++++++++--------------- 1 file changed, 27 insertions(+), 24 deletions(-) diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 247ce14c93..96b7130dc9 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -2,33 +2,36 @@ module ExceptionTests (tests) where import Config -import Control.Exception (ArithException (DivideByZero), - throwIO) +import Control.Exception (ArithException (DivideByZero), + throwIO) import Control.Lens -import Control.Monad.Error.Class (MonadError (throwError)) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as A -import Data.Default (Default (..)) -import Data.Text as T -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.Plugin.HLS (toResponseError) -import GHC.Base (coerce) -import Ide.Logger (Recorder, WithPriority) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Default (Default (..)) +import Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) +import qualified Development.IDE.LSP.Notifications as Notifications +import Development.IDE.Plugin.HLS (toResponseError) +import GHC.Base (coerce) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Error -import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) -import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types -import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), - mkRange) +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) import Language.LSP.Test -import LogType (Log (..)) -import Test.Hls (runSessionWithServerInTmpDir, - waitForProgressDone) +import LogType (Log (..)) +import Test.Hls (runSessionWithServerInTmpDir, + waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit @@ -118,7 +121,7 @@ pluginOrderTestCase msg err1 err2 = testCase msg $ do let pluginId = "error-order-test" plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins _ = pluginDescToIdePlugins $ + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do @@ -126,7 +129,7 @@ pluginOrderTestCase msg err1 err2 = ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do throwError err2 ] - }] + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone From f2c1c613825a74402f73b42c6c72db7b1f75ab1a Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 15:01:21 +0800 Subject: [PATCH 09/96] fix exceptionTests --- ghcide/test/exe/ExceptionTests.hs | 51 +++++++++++++++++++++++++++++-- 1 file changed, 48 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 96b7130dc9..3a1390dd13 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -2,8 +2,9 @@ module ExceptionTests (tests) where import Config +import Control.Concurrent.Async (withAsync) import Control.Exception (ArithException (DivideByZero), - throwIO) + finally, throwIO) import Control.Lens import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (liftIO) @@ -12,7 +13,10 @@ import Data.Default (Default (..)) import Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Main as IDE import Development.IDE.Plugin.HLS (toResponseError) +import Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Options (IdeTesting (..), optTesting) import GHC.Base (coerce) import Ide.Logger (Recorder, WithPriority, cmapWithPrio) @@ -30,10 +34,16 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import LogType (Log (..)) -import Test.Hls (runSessionWithServerInTmpDir, +import System.Directory (getCurrentDirectory, + setCurrentDirectory) +import System.IO.Extra (withTempDir) +import System.Process.Extra (createPipe) +import Test.Hls (hlsPluginTestRecorder, + runSessionWithServerInTmpDir, waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit +import TestUtils (getConfigFromEnv) tests :: TestTree tests = do @@ -116,6 +126,40 @@ tests = do ] ] +testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> FilePath -> IDE.Arguments +testingLite recorder plugins fp = + let + arguments@IDE.Arguments{ argsIdeOptions } = + IDE.defaultArguments fp (cmapWithPrio LogIDEMain recorder) plugins + hlsPlugins = pluginDescToIdePlugins $ + idePluginsToPluginDesc plugins + ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions config sessionLoader = + let + defOptions = argsIdeOptions config sessionLoader + in + defOptions{ optTesting = IdeTesting True } + in + arguments + { IDE.argsHlsPlugins = hlsPlugins + , IDE.argsIdeOptions = ideOptions + } + +testIde :: Recorder (WithPriority Log) -> (FilePath -> IDE.Arguments) -> Session () -> IO () +testIde recorder arguments session = do + config <- getConfigFromEnv + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + withTempDir $ \dir -> do + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) (arguments dir) + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps dir session + pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree pluginOrderTestCase msg err1 err2 = testCase msg $ do @@ -130,7 +174,8 @@ pluginOrderTestCase msg err1 err2 = throwError err2 ] }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do + recorder <- hlsPluginTestRecorder + testIde recorder (testingLite recorder (plugins recorder)) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) From 308e726658f5e02da8d97713a9de9129e65c0762 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 15:24:52 +0800 Subject: [PATCH 10/96] fix --- ghcide/test/exe/ExceptionTests.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 3a1390dd13..d862b2303e 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -60,7 +60,8 @@ tests = do pure (InL []) ] }] - runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do + recorder <- hlsPluginTestRecorder + testIde recorder (testingLite recorder (plugins recorder)) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -82,7 +83,8 @@ tests = do pure (InR Null) ] }] - runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do + recorder <- hlsPluginTestRecorder + testIde recorder (testingLite recorder (plugins recorder)) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -108,7 +110,8 @@ tests = do pure (InL []) ] }] - runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do + recorder <- hlsPluginTestRecorder + testIde recorder (testingLite recorder (plugins recorder)) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) From 2baa0c93b6c567dbdf370a0d14f544283b9d8085 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 16:04:27 +0800 Subject: [PATCH 11/96] fix hls --- .../src/Development/IDE/LSP/LanguageServer.hs | 18 +++--- ghcide/src/Development/IDE/Main.hs | 2 +- hls-test-utils/src/Test/Hls.hs | 56 ++++++++++--------- plugins/hls-splice-plugin/test/Main.hs | 2 +- 4 files changed, 40 insertions(+), 38 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e1b5c664d9..1f0d3b6d5d 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -125,7 +125,8 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh setupLSP :: forall config err. - Recorder (WithPriority Log) + FilePath -- ^ root directory + -> Recorder (WithPriority Log) -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) @@ -133,7 +134,7 @@ setupLSP :: -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do +setupLSP root recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan @@ -176,7 +177,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let doInitialize = handleInit root recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO @@ -184,7 +185,8 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do handleInit - :: Recorder (WithPriority Log) + :: FilePath + -> Recorder (WithPriority Log) -> (FilePath -> IO FilePath) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () @@ -193,11 +195,9 @@ handleInit -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit rootDir recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - let root = LSP.resRootPath env - dir <- maybe (error "No root directory") pure root - dbLoc <- getHieDbLoc dir + dbLoc <- getHieDbLoc rootDir let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig dbMVar <- newEmptyMVar @@ -240,7 +240,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa logWith recorder Info LogReactorThreadStopped (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env dir withHieDb hieChan + ide <- getIdeState env rootDir withHieDb hieChan registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 8dd62c3f14..a41d9199e0 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -357,7 +357,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putMVar ideStateVar ide pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup = setupLSP argsProjectRoot (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState -- See Note [Client configuration in Rules] onConfigChange cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 7eefddba6e..66fead53b9 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -415,6 +415,33 @@ runSessionWithServerInTmpDir' :: Session a -> IO a runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) +runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) -> IO a +runWithLockInTempDir tree act = withLock lockForTempDirs $ do + testRoot <- setupTestEnvironment + helperRecorder <- hlsHelperTestRecorder + -- Do not clean up the temporary directory if this variable is set to anything but '0'. + -- Aids debugging. + cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" + let runTestInDir action = case cleanupTempDir of + Just val | val /= "0" -> do + (tempDir, _) <- newTempDirWithin testRoot + a <- action tempDir + logWith helperRecorder Debug LogNoCleanup + pure a + + _ -> do + (tempDir, cleanup) <- newTempDirWithin testRoot + a <- action tempDir `finally` cleanup + logWith helperRecorder Debug LogCleanup + pure a + runTestInDir $ \tmpDir' -> do + -- we canonicalize the path, so that we do not need to do + -- cannibalization during the test when we compare two paths + tmpDir <- canonicalizePath tmpDir' + logWith helperRecorder Info $ LogTestDir tmpDir + fs <- FS.materialiseVFT tmpDir tree + act fs + -- | Host a server, and run a test session on it. -- -- Creates a temporary directory, and materializes the VirtualFileTree @@ -449,33 +476,8 @@ runSessionWithServerInTmpDirCont :: ClientCapabilities -> VirtualFileTree -> (FileSystem -> Session a) -> IO a -runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = withLock lockForTempDirs $ do - testRoot <- setupTestEnvironment - helperRecorder <- hlsHelperTestRecorder - - -- Do not clean up the temporary directory if this variable is set to anything but '0'. - -- Aids debugging. - cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" - let runTestInDir action = case cleanupTempDir of - Just val | val /= "0" -> do - (tempDir, _) <- newTempDirWithin testRoot - a <- action tempDir - logWith helperRecorder Debug LogNoCleanup - pure a - - _ -> do - (tempDir, cleanup) <- newTempDirWithin testRoot - a <- action tempDir `finally` cleanup - logWith helperRecorder Debug LogCleanup - pure a - - runTestInDir $ \tmpDir' -> do - -- we canonicalize the path, so that we do not need to do - -- cannibalization during the test when we compare two paths - tmpDir <- canonicalizePath tmpDir' - logWith helperRecorder Info $ LogTestDir tmpDir - fs <- FS.materialiseVFT tmpDir tree - runSessionWithServer' disableKick plugins conf sessConf caps tmpDir (act fs) +runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = + runWithLockInTempDir tree $ \fs -> runSessionWithServer' disableKick plugins conf sessConf caps (fsRoot fs) (act fs) runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = do diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 96f73ea4fb..12a4db4dd8 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -89,7 +89,7 @@ goldenTestWithEdit fp expect tc line col = } waitForAllProgressDone -- cradle waitForAllProgressDone - alt <- liftIO $ T.readFile (fp <.> "error.hs") + alt <- liftIO $ T.readFile (testDataDir fp <.> "error.hs") void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial {_range = theRange, _rangeLength = Nothing, _text = alt} From 2ebfafcea751adb8d0be9c1ad9c40a4f8771f261 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 18:22:57 +0800 Subject: [PATCH 12/96] use lsp root dir --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 1f0d3b6d5d..1ea8dd6a1a 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -197,7 +197,9 @@ handleInit -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) handleInit rootDir recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - dbLoc <- getHieDbLoc rootDir + let rootMaybe = LSP.resRootPath env + let root = fromMaybe rootDir rootMaybe + dbLoc <- getHieDbLoc root let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig dbMVar <- newEmptyMVar @@ -240,7 +242,7 @@ handleInit rootDir recorder getHieDbLoc getIdeState lifetime exitClientMsg clear logWith recorder Info LogReactorThreadStopped (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env rootDir withHieDb hieChan + ide <- getIdeState env root withHieDb hieChan registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) From 042df9893c036676302c32a095c3a28c95ce67bc Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 19:42:55 +0800 Subject: [PATCH 13/96] disable stan test --- .github/workflows/test.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index b86b6b8302..f0ca3d8b58 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -161,9 +161,9 @@ jobs: name: Test hls-splice-plugin run: cabal test hls-splice-plugin-tests || cabal test hls-splice-plugin-tests - - if: matrix.test && matrix.ghc != '9.2' - name: Test hls-stan-plugin - run: cabal test hls-stan-plugin-tests || cabal test hls-stan-plugin-tests + # - if: matrix.test && matrix.ghc != '9.2' + # name: Test hls-stan-plugin + # run: cabal test hls-stan-plugin-tests || cabal test hls-stan-plugin-tests - if: matrix.test name: Test hls-stylish-haskell-plugin From f8f37a0339efe0eaf36cff5e5e5fca47d006ccf5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 21:39:40 +0800 Subject: [PATCH 14/96] Revert "disable stan test" This reverts commit 042df9893c036676302c32a095c3a28c95ce67bc. --- .github/workflows/test.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index f0ca3d8b58..b86b6b8302 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -161,9 +161,9 @@ jobs: name: Test hls-splice-plugin run: cabal test hls-splice-plugin-tests || cabal test hls-splice-plugin-tests - # - if: matrix.test && matrix.ghc != '9.2' - # name: Test hls-stan-plugin - # run: cabal test hls-stan-plugin-tests || cabal test hls-stan-plugin-tests + - if: matrix.test && matrix.ghc != '9.2' + name: Test hls-stan-plugin + run: cabal test hls-stan-plugin-tests || cabal test hls-stan-plugin-tests - if: matrix.test name: Test hls-stylish-haskell-plugin From 6a11d1ec981e21bad7cea68a533e1fe66e5e4ff8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 21:45:03 +0800 Subject: [PATCH 15/96] special function that shift to root --- hls-test-utils/src/Test/Hls.hs | 24 +++++++++++++++++++++++- plugins/hls-hlint-plugin/test/Main.hs | 2 +- plugins/hls-stan-plugin/test/Main.hs | 4 +++- 3 files changed, 27 insertions(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 66fead53b9..e46dd357ca 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -33,6 +33,7 @@ module Test.Hls runSessionWithServerAndCapsInTmpDir, runSessionWithServerNoRootLock, runSessionWithServer', + runSessionWithServer'', runSessionWithServerInTmpDir', -- continuation version that take a FileSystem runSessionWithServerInTmpDirCont, @@ -683,7 +684,7 @@ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = d pure x -- | Host a server, and run a test session on it --- Note: cwd will be shifted into @root@ in @Session a@ +-- Note: cwd will not be shifted into @root@ in @Session a@ runSessionWithServer' :: (Pretty b) => -- | whether we disable the kick action or not @@ -701,6 +702,27 @@ runSessionWithServer' :: runSessionWithServer' disableKick pluginsDp conf sconf caps root s = withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s +-- | Host a server, and run a test session on it +-- Note: cwd will be shifted into @root@ in @Session a@ +runSessionWithServer'' :: + (Pretty b) => + -- | whether we disable the kick action or not + Bool -> + -- | Plugin to load on the server. + PluginTestDescriptor b -> + -- | lsp config for the server + Config -> + -- | config for the test session + SessionConfig -> + ClientCapabilities -> + FilePath -> + Session a -> + IO a +runSessionWithServer'' disableKick pluginsDp conf sconf caps root s = + withLock lock $ keepCurrentDirectory $ do + setCurrentDirectory root + runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s + -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 4cd15f9dac..be51ebb218 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -341,7 +341,7 @@ testDir :: FilePath testDir = "plugins/hls-hlint-plugin/test/testdata" runHlintSession :: FilePath -> Session a -> IO a -runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir subdir) +runHlintSession subdir = failIfSessionTimeout . runSessionWithServer'' False hlintPlugin def def codeActionNoResolveCaps (testDir subdir) noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index 650760c9dc..1564bc06d0 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -5,6 +5,7 @@ where import Control.Lens ((^.)) import qualified Data.Text as T +import Debug.Trace (traceM) import qualified Ide.Plugin.Stan as Stan import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -34,6 +35,7 @@ tests = runStanSession "" $ do doc <- openDoc ("dir" "configTest.hs") "haskell" diags <- waitForDiagnosticsFromSource doc "stan" + traceM $ show diags liftIO $ length diags @?= 0 return () , testCase "respects LANGUAGE pragmas in the source file" $ @@ -75,4 +77,4 @@ stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" runStanSession :: FilePath -> Session a -> IO a runStanSession subdir = - failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir subdir) + failIfSessionTimeout . runSessionWithServer'' False stanPlugin def def codeActionNoResolveCaps (testDir subdir) From 7dce0f3dd1f8a08c20f713857db35b987b75676d Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 21:54:53 +0800 Subject: [PATCH 16/96] remove trace --- plugins/hls-stan-plugin/test/Main.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index 1564bc06d0..d7d50e92e5 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -5,7 +5,6 @@ where import Control.Lens ((^.)) import qualified Data.Text as T -import Debug.Trace (traceM) import qualified Ide.Plugin.Stan as Stan import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -35,7 +34,6 @@ tests = runStanSession "" $ do doc <- openDoc ("dir" "configTest.hs") "haskell" diags <- waitForDiagnosticsFromSource doc "stan" - traceM $ show diags liftIO $ length diags @?= 0 return () , testCase "respects LANGUAGE pragmas in the source file" $ From 289528ab135457a885649b46881bc98c730df3dc Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 14 May 2024 22:40:00 +0800 Subject: [PATCH 17/96] use absolute root --- hls-test-utils/src/Test/Hls.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index e46dd357ca..0cb55b7a0a 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -115,6 +115,7 @@ import System.Directory (canonicalizePath, createDirectoryIfMissing, getCurrentDirectory, getTemporaryDirectory, + makeAbsolute, setCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath @@ -718,8 +719,9 @@ runSessionWithServer'' :: FilePath -> Session a -> IO a -runSessionWithServer'' disableKick pluginsDp conf sconf caps root s = +runSessionWithServer'' disableKick pluginsDp conf sconf caps relativeRoot s = withLock lock $ keepCurrentDirectory $ do + root <- makeAbsolute relativeRoot setCurrentDirectory root runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s From ca1c2b84b3f71e14aaf6d6839c1a240d5e17b608 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 15 May 2024 10:24:02 +0800 Subject: [PATCH 18/96] change to test config --- ghcide/test/exe/BootTests.hs | 5 +- ghcide/test/exe/Config.hs | 18 +- ghcide/test/exe/DependentFileTest.hs | 5 +- ghcide/test/exe/DiagnosticTests.hs | 14 +- ghcide/test/exe/IfaceTests.hs | 18 +- ghcide/test/exe/ReferenceTests.hs | 4 +- hls-test-utils/src/Test/Hls.hs | 236 +++++++++++++++----------- plugins/hls-hlint-plugin/test/Main.hs | 6 +- plugins/hls-stan-plugin/test/Main.hs | 4 +- test/functional/Config.hs | 4 +- 10 files changed, 177 insertions(+), 137 deletions(-) diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs index 0d92dbe136..078281d391 100644 --- a/ghcide/test/exe/BootTests.hs +++ b/ghcide/test/exe/BootTests.hs @@ -16,6 +16,7 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import System.FilePath (()) import Test.Hls.FileSystem (toAbsFp) import Test.Tasty import Test.Tasty.HUnit @@ -24,7 +25,7 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "boot" [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir `toAbsFp` "C.hs" + let cPath = dir "C.hs" cSource <- liftIO $ readFileUtf8 cPath -- Dirty the cache liftIO $ runInDir dir $ do @@ -51,6 +52,6 @@ tests = testGroup "boot" let floc = mkR 9 0 9 1 checkDefs locs (pure [floc]) , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir `toAbsFp` "A.hs") "haskell" + _ <- openDoc (dir "A.hs") "haskell" expectNoMoreDiagnostics 2 ] diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 0a7751fc4b..13d192c909 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -52,37 +52,37 @@ dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dum runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin -runWithDummyPlugin' :: FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a +runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin -runWithDummyPluginAndCap' :: ClientCapabilities -> (FileSystem -> Session ()) -> IO () +runWithDummyPluginAndCap' :: ClientCapabilities -> (FilePath -> Session ()) -> IO () runWithDummyPluginAndCap' cap = runSessionWithServerAndCapsInTmpDirCont def dummyPlugin cap (mkIdeTestFs []) -testWithDummyPluginAndCap' :: String -> ClientCapabilities -> (FileSystem -> Session ()) -> TestTree +testWithDummyPluginAndCap' :: String -> ClientCapabilities -> (FilePath -> Session ()) -> TestTree testWithDummyPluginAndCap' caseName cap = testCase caseName . runWithDummyPluginAndCap' cap testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const -testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FileSystem -> Session ()) -> TestTree +testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FilePath -> Session ()) -> TestTree testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs testWithDummyPluginEmpty :: String -> Session () -> TestTree testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs [] -testWithDummyPluginEmpty' :: String -> (FileSystem -> Session ()) -> TestTree +testWithDummyPluginEmpty' :: String -> (FilePath -> Session ()) -> TestTree testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs [] -runWithExtraFiles :: String -> (FileSystem -> Session a) -> IO a +runWithExtraFiles :: String -> (FilePath -> Session a) -> IO a runWithExtraFiles dirName action = do let vfs = mkIdeTestFs [FS.copyDir dirName] runWithDummyPlugin' vfs action -testWithExtraFiles :: String -> String -> (FileSystem -> Session ()) -> TestTree +testWithExtraFiles :: String -> String -> (FilePath -> Session ()) -> TestTree testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action -runInDir :: FileSystem -> Session a -> IO a -runInDir fs = runSessionWithServerNoRootLock False dummyPlugin def def def (fsRoot fs) +runInDir :: FilePath -> Session a -> IO a +runInDir fs = runSessionWithServer def dummyPlugin fs pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index f417a13bbd..86541af7ad 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -16,6 +16,7 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import System.Directory (setCurrentDirectory) +import System.FilePath (()) import Test.Hls.FileSystem (FileSystem, toAbsFp) import Test.Tasty @@ -24,11 +25,11 @@ tests = testGroup "addDependentFile" [testGroup "file-changed" [testWithDummyPluginEmpty' "test" test] ] where - test :: FileSystem -> Session () + test :: FilePath -> Session () test dir = do -- If the file contains B then no type error -- otherwise type error - let depFilePath = toAbsFp dir "dep-file.txt" + let depFilePath = dir "dep-file.txt" liftIO $ writeFile depFilePath "A" let fooContent = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 1c5adff70d..7f2c3ed4b2 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -178,11 +178,11 @@ tests = testGroup "diagnostics" [ "module ModuleB where" , "import ModuleA ()" ] - _ <- createDoc (tmpDir `toAbsFp` "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir `toAbsFp` "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir `toAbsFp` "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir `toAbsFp` "ModuleB.hs", [])] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] , testWithDummyPluginEmpty "cyclic module dependency" $ do let contentA = T.unlines [ "module ModuleA where" @@ -452,9 +452,9 @@ tests = testGroup "diagnostics" ) ] , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" - aPath = dir `toAbsFp` "A.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs index 24d5115f3a..90d27c445b 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -35,9 +35,9 @@ tests = testGroup "Interface loading tests" -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do - let aPath = dir `toAbsFp` "THA.hs" - bPath = dir `toAbsFp` "THB.hs" - cPath = dir `toAbsFp` "THC.hs" + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () _bSource <- liftIO $ readFileUtf8 bPath -- a :: () @@ -58,8 +58,8 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do ifaceErrorTest :: TestTree ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do configureCheckProject True - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int @@ -106,8 +106,8 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do ifaceErrorTest2 :: TestTree ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int @@ -140,8 +140,8 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do ifaceErrorTest3 :: TestTree ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index cf8576d12b..729e919541 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -171,11 +171,11 @@ getReferences' (file, l, c) includeDeclaration = do referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree referenceTestSession name thisDoc docs' f = do testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do - let rootDir = toAbsFp fs "" + let rootDir = fs "" -- needed to build whole project indexing configureCheckProject True -- need to get the real paths through links - docs <- mapM (liftIO . canonicalizePath . toAbsFp fs) $ delete thisDoc $ nubOrd docs' + docs <- mapM (liftIO . canonicalizePath . (fs )) $ delete thisDoc $ nubOrd docs' -- Initial Index docid <- openDoc thisDoc "haskell" diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 0cb55b7a0a..1aa84ab10d 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -31,14 +32,13 @@ module Test.Hls runSessionWithServerAndCaps, runSessionWithServerInTmpDir, runSessionWithServerAndCapsInTmpDir, - runSessionWithServerNoRootLock, - runSessionWithServer', - runSessionWithServer'', + runSessionWithServerAndCapsShift, runSessionWithServerInTmpDir', -- continuation version that take a FileSystem runSessionWithServerInTmpDirCont, runSessionWithServerInTmpDirCont', runSessionWithServerAndCapsInTmpDirCont, + runSessionWithTestConfig, -- * Helpful re-exports PluginDescriptor, IdeState, @@ -64,6 +64,8 @@ module Test.Hls WithPriority(..), Recorder, Priority(..), + TestConfig(..), + mkTestConfig, ) where @@ -72,7 +74,7 @@ import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe import Control.Lens.Extras (is) -import Control.Monad (guard, unless, void) +import Control.Monad (guard, unless, void, when) import Control.Monad.Extra (forM) import Control.Monad.IO.Class import Data.Aeson (Result (Success), @@ -105,6 +107,8 @@ import Ide.Logger (Pretty (pretty), logWith, makeDefaultStderrRecorder, (<+>)) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message @@ -396,11 +400,11 @@ runSessionWithServerInTmpDir config plugin tree act = runSessionWithServerInTmpD runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a runSessionWithServerAndCapsInTmpDir config plugin caps tree act = runSessionWithServerAndCapsInTmpDirCont config plugin caps tree (const act) -runSessionWithServerInTmpDirCont' :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> (FileSystem -> Session a) -> IO a +runSessionWithServerInTmpDirCont' :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> (FilePath -> Session a) -> IO a runSessionWithServerInTmpDirCont' config plugin tree act = do runSessionWithServerInTmpDirCont False plugin config def fullCaps tree act -runSessionWithServerAndCapsInTmpDirCont :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> (FileSystem -> Session a) -> IO a +runSessionWithServerAndCapsInTmpDirCont :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> (FilePath -> Session a) -> IO a runSessionWithServerAndCapsInTmpDirCont config plugin caps tree act = do runSessionWithServerInTmpDirCont False plugin config def caps tree act @@ -415,7 +419,8 @@ runSessionWithServerInTmpDir' :: ClientCapabilities -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) +runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = + runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) -> IO a runWithLockInTempDir tree act = withLock lockForTempDirs $ do @@ -477,17 +482,37 @@ runSessionWithServerInTmpDirCont :: SessionConfig -> ClientCapabilities -> VirtualFileTree -> - (FileSystem -> Session a) -> IO a + (FilePath -> Session a) -> IO a runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = - runWithLockInTempDir tree $ \fs -> runSessionWithServer' disableKick plugins conf sessConf caps (fsRoot fs) (act fs) + runSessionWithTestConfig (mkTestConfig "" plugins) + {testLspConfig=conf, testConfigSession=sessConf, testConfigCaps=caps, testFileTree=Just tree, testDisableKick=disableKick} + act runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a -runSessionWithServer config plugin fp act = do - runSessionWithServer' False plugin config def fullCaps fp act +runSessionWithServer config plugin fp act = + runSessionWithTestConfig (mkTestConfig fp plugin){testLspConfig=config} (const act) runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithServerAndCaps config plugin caps fp act = do - runSessionWithServer' False plugin config def caps fp act +runSessionWithServerAndCaps config plugin caps root act = + runSessionWithTestConfig (mkTestConfig root plugin){testConfigCaps=caps, testLspConfig=config} (const act) + +runSessionWithServerAndCapsShift :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a +runSessionWithServerAndCapsShift config plugin caps root act = + runSessionWithTestConfig (mkTestConfig root plugin){testConfigCaps=caps, testLspConfig=config, testShiftRoot=True} (const act) + +mkTestConfig :: FilePath -> PluginTestDescriptor b -> TestConfig b +mkTestConfig fp pd = TestConfig { + testConfigRoot = fp, + testFileTree = Nothing, + testShiftRoot = False, + testDisableKick = False, + testDisableDefaultPlugin = False, + testPluginDescriptor = pd, + testLspConfig = def, + testConfigSession = def, + testConfigCaps = fullCaps +} + -- | Setup the test environment for isolated tests. @@ -621,60 +646,54 @@ lock = unsafePerformIO newLock lockForTempDirs :: Lock lockForTempDirs = unsafePerformIO newLock --- | Host a server, and run a test session on it --- Note: cwd will be shifted into @root@ in @Session a@ --- notice this function should only be used in tests that --- require to be nested in the same temporary directory --- use 'runSessionWithServerInTmpDir' for other cases -runSessionWithServerNoRootLock :: - (Pretty b) => - -- | whether we disable the kick action or not - Bool -> - -- | Plugin to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - FilePath -> - Session a -> - IO a -runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = do + +-- -- | Host a server, and run a test session on it +-- -- Note: cwd will not be shifted into @root@ in @Session a@ +-- runSessionWithServer' :: +-- (Pretty b) => +-- -- | whether we disable the kick action or not +-- Bool -> +-- -- | Plugin to load on the server. +-- PluginTestDescriptor b -> +-- -- | lsp config for the server +-- Config -> +-- -- | config for the test session +-- SessionConfig -> +-- ClientCapabilities -> +-- FilePath -> +-- Session a -> +-- IO a +-- runSessionWithServer' disableKick pluginsDp conf sconf caps root s = +-- withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s + +data TestConfig b = TestConfig + { + testConfigRoot :: FilePath + , testFileTree :: Maybe VirtualFileTree + , testShiftRoot :: Bool + , testDisableKick :: Bool + , testDisableDefaultPlugin :: Bool + , testPluginDescriptor :: PluginTestDescriptor b + , testLspConfig :: Config + , testConfigSession :: SessionConfig + , testConfigCaps :: ClientCapabilities + } + +runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a +runSessionWithTestConfig TestConfig{..} session = + runSessionInVFS testFileTree $ \root -> shiftRoot root $ do (inR, inW) <- createPipe (outR, outW) <- createPipe recorder <- hlsPluginTestRecorder - let plugins = pluginsDp recorder + let plugins = testPluginDescriptor recorder recorderIde <- hlsHelperTestRecorder - - let - sconf' = sconf { lspConfig = hlsConfigToClientConfig conf } - - hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins - - arguments@Arguments{ argsIdeOptions } = - testing root (cmapWithPrio LogIDEMain recorderIde) hlsPlugins - - ideOptions config ghcSession = - let defIdeOptions = argsIdeOptions config ghcSession - in defIdeOptions - { optTesting = IdeTesting True - , optCheckProject = pure False - } - + let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig } + arguments = testingArgs root (cmapWithPrio LogIDEMain recorderIde) plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) - arguments - { argsHandleIn = pure inR - , argsHandleOut = pure outW - , argsDefaultHlsConfig = conf - , argsIdeOptions = ideOptions - , argsProjectRoot = root - , argsDisableKick = disableKick - } - - x <- runSessionWithHandles inW outR sconf' caps root s + arguments { argsHandleIn = pure inR , argsHandleOut = pure outW } + result <- runSessionWithHandles inW outR sconf' testConfigCaps root (session root) hClose inW timeout 3 (wait server) >>= \case Just () -> pure () @@ -682,48 +701,61 @@ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = d putStrLn "Server does not exit in 3s, canceling the async task..." (t, _) <- duration $ cancel server putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" - pure x - --- | Host a server, and run a test session on it --- Note: cwd will not be shifted into @root@ in @Session a@ -runSessionWithServer' :: - (Pretty b) => - -- | whether we disable the kick action or not - Bool -> - -- | Plugin to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - FilePath -> - Session a -> - IO a -runSessionWithServer' disableKick pluginsDp conf sconf caps root s = - withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s - --- | Host a server, and run a test session on it --- Note: cwd will be shifted into @root@ in @Session a@ -runSessionWithServer'' :: - (Pretty b) => - -- | whether we disable the kick action or not - Bool -> - -- | Plugin to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - FilePath -> - Session a -> - IO a -runSessionWithServer'' disableKick pluginsDp conf sconf caps relativeRoot s = - withLock lock $ keepCurrentDirectory $ do - root <- makeAbsolute relativeRoot - setCurrentDirectory root - runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s + pure result + + where + shiftRoot shiftTarget f = + if testShiftRoot + then withLock lock $ keepCurrentDirectory $ setCurrentDirectory shiftTarget >> f + else f + runSessionInVFS Nothing act = do + root <- makeAbsolute testConfigRoot + act root + runSessionInVFS (Just vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) + -- testingArgs :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments + testingArgs prjRoot recorder plugins = + let + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments prjRoot recorder plugins + argsHlsPlugins' = if testDisableDefaultPlugin then plugins else argsHlsPlugins + hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins' + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions config sessionLoader = (argsIdeOptions config sessionLoader){ + optTesting = IdeTesting True + , optCheckProject = pure False + } + in + arguments + { argsHlsPlugins = hlsPlugins + , argsIdeOptions = ideOptions + , argsDefaultHlsConfig = testLspConfig + , argsProjectRoot = prjRoot + , argsDisableKick = testDisableKick + } + + + + +-- -- | Host a server, and run a test session on it +-- -- Note: cwd will be shifted into @root@ in @Session a@ +-- runSessionWithServer'' :: +-- (Pretty b) => +-- -- | whether we disable the kick action or not +-- Bool -> +-- -- | Plugin to load on the server. +-- PluginTestDescriptor b -> +-- -- | lsp config for the server +-- Config -> +-- -- | config for the test session +-- SessionConfig -> +-- ClientCapabilities -> +-- FilePath -> +-- Session a -> +-- IO a +-- runSessionWithServer'' disableKick pluginsDp conf sconf caps relativeRoot s = +-- withLock lock $ keepCurrentDirectory $ do +-- root <- makeAbsolute relativeRoot +-- setCurrentDirectory root +-- runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s -- | Wait for the next progress begin step waitForProgressBegin :: Session () diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index be51ebb218..73d0c2c7c3 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -116,7 +116,7 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps testDir $ do + , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCapsShift def hlintPlugin noLiteralCaps testDir $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" @@ -341,7 +341,9 @@ testDir :: FilePath testDir = "plugins/hls-hlint-plugin/test/testdata" runHlintSession :: FilePath -> Session a -> IO a -runHlintSession subdir = failIfSessionTimeout . runSessionWithServer'' False hlintPlugin def def codeActionNoResolveCaps (testDir subdir) +runHlintSession subdir = failIfSessionTimeout . + runSessionWithTestConfig (mkTestConfig (testDir subdir) hlintPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + . const noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index d7d50e92e5..5f507989d7 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -75,4 +75,6 @@ stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" runStanSession :: FilePath -> Session a -> IO a runStanSession subdir = - failIfSessionTimeout . runSessionWithServer'' False stanPlugin def def codeActionNoResolveCaps (testDir subdir) + failIfSessionTimeout + . runSessionWithTestConfig (mkTestConfig (testDir subdir) stanPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + . const diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 1dbf12c64c..1db1601d1b 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -68,7 +68,9 @@ genericConfigTests = testGroup "generic plugin config" testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])] runConfigSession subdir session = do - failIfSessionTimeout $ runSessionWithServer' @() False plugin def (def {ignoreConfigurationRequests=False}) fullCaps ("test/testdata" subdir) session + failIfSessionTimeout $ + runSessionWithTestConfig (mkTestConfig ("test/testdata" subdir) plugin) + {testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True} (const session) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics From a3dc7cea6ba733a29e72d5348e212d272b0cea7a Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 15 May 2024 18:41:18 +0800 Subject: [PATCH 19/96] add goldenWithTestConfig --- hls-test-utils/src/Test/Hls.hs | 21 +++++++++++++++++++++ plugins/hls-hlint-plugin/test/Main.hs | 5 ++++- 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 1aa84ab10d..6a9da5d825 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -26,6 +26,7 @@ module Test.Hls goldenWithHaskellDocFormatterInTmpDir, goldenWithCabalDocFormatter, goldenWithCabalDocFormatterInTmpDir, + goldenWithTestConfig, def, -- * Running HLS for integration tests runSessionWithServer, @@ -215,6 +216,26 @@ goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ex act doc documentContents doc +goldenWithTestConfig + :: Pretty b + => TestConfig b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithTestConfig config title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithTestConfig config $ const + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue + act doc + documentContents doc + goldenWithHaskellAndCapsInTmpDir :: Pretty b => Config diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 73d0c2c7c3..0ce6890944 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -421,9 +421,12 @@ goldenTest testCaseName goldenFilename point hintText = void $ skipManyTill anyMessage $ getDocumentEdit document _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithTestConfig (mkTestConfig testDir hlintPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + testName testDir path "expected" "hs" + ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = From 1d0f5449bf12e7cad6a088f85327939e1dde819b Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 15 May 2024 18:50:50 +0800 Subject: [PATCH 20/96] fix --- plugins/hls-hlint-plugin/test/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 0ce6890944..47060cd8c1 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -447,4 +447,5 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithTestConfig (mkTestConfig testDir hlintPlugin){testConfigCaps=codeActionResolveCaps, testShiftRoot=True} + testName testDir path "expected" "hs" From 725473103ee881152f7dbd7378937caccad4ba1f Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 15 May 2024 19:20:20 +0800 Subject: [PATCH 21/96] fix notes --- plugins/hls-notes-plugin/test/NotesTest.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs index e42ef407d7..8eae6b011c 100644 --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -17,13 +17,14 @@ main = defaultTestRunner $ gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition" - [ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do + [ + testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" waitForBuildQueue waitForAllProgressDone defs <- getDefinitions doc (Position 3 41) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" @@ -31,7 +32,7 @@ gotoNoteTests = testGroup "Goto Note Definition" waitForAllProgressDone defs <- getDefinitions doc (Position 5 64) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do @@ -56,7 +57,7 @@ gotoNoteTests = testGroup "Goto Note Definition" waitForAllProgressDone defs <- getDefinitions doc (Position 5 20) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) ] From 2a25a1f39c6b1df76a87c6d366b61032820f4127 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 15 May 2024 22:09:02 +0800 Subject: [PATCH 22/96] fix windows --- ghcide/test/exe/DependentFileTest.hs | 6 ++++-- hls-test-utils/src/Test/Hls.hs | 16 +++++++++++++++- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index 86541af7ad..8d9cc6772b 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -19,17 +19,19 @@ import System.Directory (setCurrentDirectory) import System.FilePath (()) import Test.Hls.FileSystem (FileSystem, toAbsFp) import Test.Tasty +import Test.Hls + tests :: TestTree tests = testGroup "addDependentFile" - [testGroup "file-changed" [testWithDummyPluginEmpty' "test" test] + [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig (mkTestConfig "" dummyPlugin) {testShiftRoot=True, testFileTree=Just (mkIdeTestFs [])} test] ] where test :: FilePath -> Session () test dir = do -- If the file contains B then no type error -- otherwise type error - let depFilePath = dir "dep-file.txt" + let depFilePath = "dep-file.txt" liftIO $ writeFile depFilePath "A" let fooContent = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 6a9da5d825..1c3246a421 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -83,7 +83,7 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) -import Data.Default (def) +import Data.Default (def, Default) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) @@ -520,6 +520,20 @@ runSessionWithServerAndCaps config plugin caps root act = runSessionWithServerAndCapsShift :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a runSessionWithServerAndCapsShift config plugin caps root act = runSessionWithTestConfig (mkTestConfig root plugin){testConfigCaps=caps, testLspConfig=config, testShiftRoot=True} (const act) + +instance Default (TestConfig b) where + def = TestConfig { + testConfigRoot = "", + testFileTree = Nothing, + testShiftRoot = False, + testDisableKick = False, + testDisableDefaultPlugin = False, + testPluginDescriptor = mempty, + testLspConfig = def, + testConfigSession = def, + testConfigCaps = fullCaps + } + mkTestConfig :: FilePath -> PluginTestDescriptor b -> TestConfig b mkTestConfig fp pd = TestConfig { From 39978499f862138ef4e6480994da875b349c8dad Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 15 May 2024 22:36:08 +0800 Subject: [PATCH 23/96] relatex test --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index d7339b4d80..9d7363e1cb 100644 --- a/cabal.project +++ b/cabal.project @@ -19,7 +19,7 @@ write-ghc-environment-files: never -- Many of our tests only work single-threaded, and the only way to -- ensure tasty runs everything purely single-threaded is to pass -- this at the top-level -test-options: -j1 +-- test-options: -j1 -- Make sure dependencies are build with haddock so we get -- haddock shown on hover From e2ff7d097aef1b47e8d0c07fbcdcadc8b6b35e72 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 08:39:08 +0800 Subject: [PATCH 24/96] migrate exception tests --- ghcide/test/exe/ExceptionTests.hs | 66 +++++-------------------------- hls-test-utils/src/Test/Hls.hs | 8 ++-- 2 files changed, 13 insertions(+), 61 deletions(-) diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index d862b2303e..a734e0529c 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -1,10 +1,8 @@ module ExceptionTests (tests) where -import Config -import Control.Concurrent.Async (withAsync) import Control.Exception (ArithException (DivideByZero), - finally, throwIO) + throwIO) import Control.Lens import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (liftIO) @@ -13,17 +11,13 @@ import Data.Default (Default (..)) import Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) import qualified Development.IDE.LSP.Notifications as Notifications -import qualified Development.IDE.Main as IDE import Development.IDE.Plugin.HLS (toResponseError) -import Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Options (IdeTesting (..), optTesting) import GHC.Base (coerce) import Ide.Logger (Recorder, WithPriority, cmapWithPrio) import Ide.Plugin.Error import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) -import Ide.PluginUtils (idePluginsToPluginDesc, - pluginDescToIdePlugins) +import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -34,16 +28,12 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import LogType (Log (..)) -import System.Directory (getCurrentDirectory, - setCurrentDirectory) -import System.IO.Extra (withTempDir) -import System.Process.Extra (createPipe) -import Test.Hls (hlsPluginTestRecorder, - runSessionWithServerInTmpDir, +import Test.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), + hlsPluginTestRecorder, + runSessionWithTestConfig, waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit -import TestUtils (getConfigFromEnv) tests :: TestTree tests = do @@ -60,8 +50,7 @@ tests = do pure (InL []) ] }] - recorder <- hlsPluginTestRecorder - testIde recorder (testingLite recorder (plugins recorder)) $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -83,8 +72,7 @@ tests = do pure (InR Null) ] }] - recorder <- hlsPluginTestRecorder - testIde recorder (testingLite recorder (plugins recorder)) $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -110,8 +98,7 @@ tests = do pure (InL []) ] }] - recorder <- hlsPluginTestRecorder - testIde recorder (testingLite recorder (plugins recorder)) $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -129,40 +116,6 @@ tests = do ] ] -testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> FilePath -> IDE.Arguments -testingLite recorder plugins fp = - let - arguments@IDE.Arguments{ argsIdeOptions } = - IDE.defaultArguments fp (cmapWithPrio LogIDEMain recorder) plugins - hlsPlugins = pluginDescToIdePlugins $ - idePluginsToPluginDesc plugins - ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ideOptions config sessionLoader = - let - defOptions = argsIdeOptions config sessionLoader - in - defOptions{ optTesting = IdeTesting True } - in - arguments - { IDE.argsHlsPlugins = hlsPlugins - , IDE.argsIdeOptions = ideOptions - } - -testIde :: Recorder (WithPriority Log) -> (FilePath -> IDE.Arguments) -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - withTempDir $ \dir -> do - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) (arguments dir) - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps dir session - pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree pluginOrderTestCase msg err1 err2 = testCase msg $ do @@ -177,8 +130,7 @@ pluginOrderTestCase msg err1 err2 = throwError err2 ] }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - recorder <- hlsPluginTestRecorder - testIde recorder (testingLite recorder (plugins recorder)) $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 1c3246a421..661a1bb608 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -83,7 +83,7 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) -import Data.Default (def, Default) +import Data.Default (Default, def) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) @@ -520,11 +520,11 @@ runSessionWithServerAndCaps config plugin caps root act = runSessionWithServerAndCapsShift :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a runSessionWithServerAndCapsShift config plugin caps root act = runSessionWithTestConfig (mkTestConfig root plugin){testConfigCaps=caps, testLspConfig=config, testShiftRoot=True} (const act) - + instance Default (TestConfig b) where def = TestConfig { testConfigRoot = "", - testFileTree = Nothing, + testFileTree = Just (VirtualFileTree [] ""), testShiftRoot = False, testDisableKick = False, testDisableDefaultPlugin = False, @@ -533,7 +533,7 @@ instance Default (TestConfig b) where testConfigSession = def, testConfigCaps = fullCaps } - + mkTestConfig :: FilePath -> PluginTestDescriptor b -> TestConfig b mkTestConfig fp pd = TestConfig { From 91d31d83de928b4b074f355de3b2de09dfa2557f Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 08:52:53 +0800 Subject: [PATCH 25/96] clean up --- hls-test-utils/src/Test/Hls.hs | 75 ++++++------------------ plugins/hls-hlint-plugin/test/Main.hs | 7 ++- plugins/hls-refactor-plugin/test/Main.hs | 5 +- plugins/hls-rename-plugin/test/Main.hs | 6 +- 4 files changed, 33 insertions(+), 60 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 661a1bb608..1277e195ec 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -30,10 +30,8 @@ module Test.Hls def, -- * Running HLS for integration tests runSessionWithServer, - runSessionWithServerAndCaps, runSessionWithServerInTmpDir, runSessionWithServerAndCapsInTmpDir, - runSessionWithServerAndCapsShift, runSessionWithServerInTmpDir', -- continuation version that take a FileSystem runSessionWithServerInTmpDirCont, @@ -208,7 +206,14 @@ goldenWithHaskellAndCaps -> TestTree goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServerAndCaps config plugin clientCaps testDataDir + $ runSessionWithTestConfig def { + testConfigRoot = testDataDir, + testConfigCaps = clientCaps, + testLspConfig = config, + testPluginDescriptor = plugin + } + $ const +-- runSessionWithServerAndCaps config plugin clientCaps testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -513,18 +518,10 @@ runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath runSessionWithServer config plugin fp act = runSessionWithTestConfig (mkTestConfig fp plugin){testLspConfig=config} (const act) -runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithServerAndCaps config plugin caps root act = - runSessionWithTestConfig (mkTestConfig root plugin){testConfigCaps=caps, testLspConfig=config} (const act) - -runSessionWithServerAndCapsShift :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithServerAndCapsShift config plugin caps root act = - runSessionWithTestConfig (mkTestConfig root plugin){testConfigCaps=caps, testLspConfig=config, testShiftRoot=True} (const act) - instance Default (TestConfig b) where def = TestConfig { testConfigRoot = "", - testFileTree = Just (VirtualFileTree [] ""), + testFileTree = Nothing, testShiftRoot = False, testDisableKick = False, testDisableDefaultPlugin = False, @@ -681,37 +678,26 @@ lock = unsafePerformIO newLock lockForTempDirs :: Lock lockForTempDirs = unsafePerformIO newLock - --- -- | Host a server, and run a test session on it --- -- Note: cwd will not be shifted into @root@ in @Session a@ --- runSessionWithServer' :: --- (Pretty b) => --- -- | whether we disable the kick action or not --- Bool -> --- -- | Plugin to load on the server. --- PluginTestDescriptor b -> --- -- | lsp config for the server --- Config -> --- -- | config for the test session --- SessionConfig -> --- ClientCapabilities -> --- FilePath -> --- Session a -> --- IO a --- runSessionWithServer' disableKick pluginsDp conf sconf caps root s = --- withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s - data TestConfig b = TestConfig { testConfigRoot :: FilePath + -- ^ Root directory of the test project , testFileTree :: Maybe VirtualFileTree + -- ^ Virtual file tree to be used for the test , testShiftRoot :: Bool + -- ^ Whether to shift the root directory to the test project root , testDisableKick :: Bool + -- ^ Whether to disable the kick action , testDisableDefaultPlugin :: Bool + -- ^ Whether to disable the default plugin comes with ghcide , testPluginDescriptor :: PluginTestDescriptor b + -- ^ Plugin to load on the server. , testLspConfig :: Config + -- ^ lsp config for the server , testConfigSession :: SessionConfig + -- ^ config for the test session , testConfigCaps :: ClientCapabilities + -- ^ Client capabilities } runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a @@ -767,31 +753,6 @@ runSessionWithTestConfig TestConfig{..} session = , argsDisableKick = testDisableKick } - - - --- -- | Host a server, and run a test session on it --- -- Note: cwd will be shifted into @root@ in @Session a@ --- runSessionWithServer'' :: --- (Pretty b) => --- -- | whether we disable the kick action or not --- Bool -> --- -- | Plugin to load on the server. --- PluginTestDescriptor b -> --- -- | lsp config for the server --- Config -> --- -- | config for the test session --- SessionConfig -> --- ClientCapabilities -> --- FilePath -> --- Session a -> --- IO a --- runSessionWithServer'' disableKick pluginsDp conf sconf caps relativeRoot s = --- withLock lock $ keepCurrentDirectory $ do --- root <- makeAbsolute relativeRoot --- setCurrentDirectory root --- runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s - -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 47060cd8c1..14f3e6f28f 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -116,7 +116,12 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCapsShift def hlintPlugin noLiteralCaps testDir $ do + , testCase "falls back to pre 3.8 code actions" $ + runSessionWithTestConfig def { + testConfigCaps = noLiteralCaps, + testConfigRoot = testDir, + testPluginDescriptor = hlintPlugin, + testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 3670a3b398..8f5e4836cd 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3751,7 +3751,10 @@ run' :: (FilePath -> Session a) -> IO a run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a -runInDir dir act = runSessionWithServerAndCaps def refactorPlugin lspTestCaps dir act +runInDir dir act = + runSessionWithTestConfig def + {testConfigRoot=dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} + $ const act lspTestCaps :: ClientCapabilities lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index dc6e99e33e..5ebb748f40 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -146,4 +146,8 @@ expectRenameError doc pos newName = do runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout - . runSessionWithServerAndCaps def renamePlugin codeActionNoResolveCaps (testDataDir subdir) + . runSessionWithTestConfig def + {testConfigRoot=testDataDir subdir, + testPluginDescriptor=renamePlugin, + testConfigCaps=codeActionNoResolveCaps} + . const From edca60d56b3e61184c223c2ab1a388820ee3ba2e Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 09:03:08 +0800 Subject: [PATCH 26/96] remove testWithDummyPluginAndCap' --- ghcide/test/exe/Config.hs | 7 ------- ghcide/test/exe/DiagnosticTests.hs | 11 +++++++++-- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 13d192c909..75885f7599 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -11,7 +11,6 @@ module Config( , testWithDummyPluginEmpty , testWithDummyPlugin' , testWithDummyPluginEmpty' - , testWithDummyPluginAndCap' , runWithExtraFiles , runInDir , testWithExtraFiles @@ -55,12 +54,6 @@ runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin -runWithDummyPluginAndCap' :: ClientCapabilities -> (FilePath -> Session ()) -> IO () -runWithDummyPluginAndCap' cap = runSessionWithServerAndCapsInTmpDirCont def dummyPlugin cap (mkIdeTestFs []) - -testWithDummyPluginAndCap' :: String -> ClientCapabilities -> (FilePath -> Session ()) -> TestTree -testWithDummyPluginAndCap' caseName cap = testCase caseName . runWithDummyPluginAndCap' cap - testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 7f2c3ed4b2..172c9f6742 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -36,7 +36,9 @@ import Control.Monad.Extra (whenJust) import Data.Default (def) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import System.Time.Extra -import Test.Hls (runSessionWithServerInTmpDirCont, +import Test.Hls (TestConfig (testConfigCaps, testLspConfig, testPluginDescriptor), + runSessionWithServerInTmpDirCont, + runSessionWithTestConfig, waitForProgressBegin) import Test.Hls.FileSystem (directCradle, file, text, toAbsFp) @@ -169,7 +171,12 @@ tests = testGroup "diagnostics" let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc "ModuleA.hs" "haskell" contentA expectDiagnostics [("ModuleB.hs", [])] - , testWithDummyPluginAndCap' "add missing module (non workspace)" lspTestCapsNoFileWatches $ \tmpDir -> do + , testCase "add missing module (non workspace)" $ + runSessionWithTestConfig def { + testPluginDescriptor = dummyPlugin + , testConfigCaps = lspTestCapsNoFileWatches + } + $ \tmpDir -> do -- By default lsp-test sends FileWatched notifications for all files, which we don't want -- as non workspace modules will not be watched by the LSP server. -- To work around this, we tell lsp-test that our client doesn't have the From 17e3305de3d7cbb7ad4a54298c6a0e26523cb2b4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 09:06:13 +0800 Subject: [PATCH 27/96] use single thread in test --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 9d7363e1cb..d7339b4d80 100644 --- a/cabal.project +++ b/cabal.project @@ -19,7 +19,7 @@ write-ghc-environment-files: never -- Many of our tests only work single-threaded, and the only way to -- ensure tasty runs everything purely single-threaded is to pass -- this at the top-level --- test-options: -j1 +test-options: -j1 -- Make sure dependencies are build with haddock so we get -- haddock shown on hover From 4c88650fdb24208e8f87776ca7e20ba4e37eeee8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 09:26:10 +0800 Subject: [PATCH 28/96] move semantic tokens test --- ghcide/test/exe/DependentFileTest.hs | 2 +- .../test/SemanticTokensTest.hs | 51 +++++++------------ 2 files changed, 18 insertions(+), 35 deletions(-) diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index 8d9cc6772b..e9cf705c3f 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -17,9 +17,9 @@ import Language.LSP.Protocol.Types hiding import Language.LSP.Test import System.Directory (setCurrentDirectory) import System.FilePath (()) +import Test.Hls import Test.Hls.FileSystem (FileSystem, toAbsFp) import Test.Tasty -import Test.Hls tests :: TestTree diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 906319ed2a..5e523a89fe 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -3,7 +3,6 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Lens ((^.), (^?)) -import Control.Monad.IO.Class (liftIO) import Data.Aeson (KeyValue (..), Object) import qualified Data.Aeson.KeyMap as KV import Data.Default @@ -15,35 +14,17 @@ import Data.Text hiding (length, map, import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (Pretty) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) -import Development.IDE.Test (waitForBuildQueue) import Ide.Plugin.SemanticTokens import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types -import Language.LSP.Test (Session, - SessionConfig (ignoreConfigurationRequests), - openDoc, request) import qualified Language.LSP.Test as Test import Language.LSP.VFS (VirtualFile (..)) import System.FilePath -import Test.Hls (HasCallStack, - PluginTestDescriptor, - SMethod (SMethod_TextDocumentSemanticTokensFullDelta), - TestName, TestTree, - changeDoc, - defaultTestRunner, - documentContents, fullCaps, - goldenGitDiff, - mkPluginTestDescriptor, - runSessionWithServerInTmpDir, - runSessionWithServerInTmpDir', - testCase, testGroup, - waitForAction, (@?=)) +import Test.Hls import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (file, text) @@ -155,20 +136,22 @@ semanticTokensConfigTest = let funcVar = KV.fromList ["functionToken" .= var] var :: String var = "variable" - do - Test.Hls.runSessionWithServerInTmpDir' - semanticTokensPlugin - (mkSemanticConfig funcVar) - def {ignoreConfigurationRequests = False} - fullCaps - fs - $ do - -- modifySemantic funcVar - void waitForBuildQueue - doc <- openDoc "Hello.hs" "haskell" - void waitForBuildQueue - result1 <- docLspSemanticTokensString doc - liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" + Test.Hls.runSessionWithTestConfig def { + testPluginDescriptor = semanticTokensPlugin + , testConfigSession = def { + ignoreConfigurationRequests = False + } + , testConfigCaps = fullCaps + , testFileTree = Just fs + , testLspConfig = mkSemanticConfig funcVar + } + $ const $ do + -- modifySemantic funcVar + void waitForBuildQueue + doc <- openDoc "Hello.hs" "haskell" + void waitForBuildQueue + result1 <- docLspSemanticTokensString doc + liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" ] semanticTokensFullDeltaTests :: TestTree From c0ed6734463b7c93a0511fe527fd7880a06f4021 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 09:39:19 +0800 Subject: [PATCH 29/96] clean up DependentFileTest --- ghcide/test/exe/DependentFileTest.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index e9cf705c3f..7255bbd1ac 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -4,7 +4,6 @@ module DependentFileTest (tests) where import Config -import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Development.IDE.Test (expectDiagnostics) import Development.IDE.Types.Location @@ -15,20 +14,20 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import System.Directory (setCurrentDirectory) -import System.FilePath (()) import Test.Hls -import Test.Hls.FileSystem (FileSystem, toAbsFp) -import Test.Tasty tests :: TestTree tests = testGroup "addDependentFile" - [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig (mkTestConfig "" dummyPlugin) {testShiftRoot=True, testFileTree=Just (mkIdeTestFs [])} test] + [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def + {testShiftRoot=True + , testFileTree=Just (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin + } test] ] where test :: FilePath -> Session () - test dir = do + test _ = do -- If the file contains B then no type error -- otherwise type error let depFilePath = "dep-file.txt" From 8223c65b59d6892053d4ac31ebcb7712f2c04db0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 09:53:18 +0800 Subject: [PATCH 30/96] merge file tree and config root --- ghcide/test/exe/Config.hs | 3 +- ghcide/test/exe/DependentFileTest.hs | 2 +- hls-test-utils/src/Test/Hls.hs | 63 ++++++------------- plugins/hls-hlint-plugin/test/Main.hs | 2 +- plugins/hls-refactor-plugin/test/Main.hs | 2 +- plugins/hls-rename-plugin/test/Main.hs | 2 +- .../test/SemanticTokensTest.hs | 2 +- 7 files changed, 24 insertions(+), 52 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 75885f7599..1313d2641e 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -36,7 +36,6 @@ import Language.LSP.Protocol.Types (Null (..)) import System.FilePath (()) import Test.Hls import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (FileSystem, fsRoot) testDataDir :: FilePath testDataDir = "ghcide" "test" "data" @@ -52,7 +51,7 @@ runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a -runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin +runWithDummyPlugin' fs = runSessionWithTestConfig def { testPluginDescriptor = dummyPlugin, testFileTree = Right fs } testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index 7255bbd1ac..f4887d56a9 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -21,7 +21,7 @@ tests :: TestTree tests = testGroup "addDependentFile" [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def {testShiftRoot=True - , testFileTree=Just (mkIdeTestFs []) + , testFileTree=Right (mkIdeTestFs []) , testPluginDescriptor = dummyPlugin } test] ] diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 1277e195ec..b88847ec02 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -31,12 +31,8 @@ module Test.Hls -- * Running HLS for integration tests runSessionWithServer, runSessionWithServerInTmpDir, - runSessionWithServerAndCapsInTmpDir, - runSessionWithServerInTmpDir', -- continuation version that take a FileSystem runSessionWithServerInTmpDirCont, - runSessionWithServerInTmpDirCont', - runSessionWithServerAndCapsInTmpDirCont, runSessionWithTestConfig, -- * Helpful re-exports PluginDescriptor, @@ -73,7 +69,7 @@ import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe import Control.Lens.Extras (is) -import Control.Monad (guard, unless, void, when) +import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) import Control.Monad.IO.Class import Data.Aeson (Result (Success), @@ -207,7 +203,7 @@ goldenWithHaskellAndCaps goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) $ runSessionWithTestConfig def { - testConfigRoot = testDataDir, + testFileTree = Left testDataDir, testConfigCaps = clientCaps, testLspConfig = config, testPluginDescriptor = plugin @@ -255,7 +251,13 @@ goldenWithHaskellAndCapsInTmpDir -> TestTree goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc ext act = goldenGitDiff title (vftOriginalRoot tree path <.> desc <.> ext) - $ runSessionWithServerAndCapsInTmpDir config plugin clientCaps tree + $ + runSessionWithTestConfig def { + testFileTree = Right tree, + testConfigCaps = clientCaps, + testLspConfig = config, + testPluginDescriptor = plugin + } $ const $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -421,32 +423,8 @@ initializeTestRecorder envVars = do -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir config plugin tree act = runSessionWithServerInTmpDirCont' config plugin tree (const act) - -runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a -runSessionWithServerAndCapsInTmpDir config plugin caps tree act = runSessionWithServerAndCapsInTmpDirCont config plugin caps tree (const act) - -runSessionWithServerInTmpDirCont' :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> (FilePath -> Session a) -> IO a -runSessionWithServerInTmpDirCont' config plugin tree act = do - runSessionWithServerInTmpDirCont False plugin config def fullCaps tree act - -runSessionWithServerAndCapsInTmpDirCont :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> (FilePath -> Session a) -> IO a -runSessionWithServerAndCapsInTmpDirCont config plugin caps tree act = do - runSessionWithServerInTmpDirCont False plugin config def caps tree act - -runSessionWithServerInTmpDir' :: - Pretty b => - -- | Plugins to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - Session a -> IO a -runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = - runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) +runSessionWithServerInTmpDir config plugin tree act = + runSessionWithServerInTmpDirCont False plugin config def fullCaps tree (const act) runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) -> IO a runWithLockInTempDir tree act = withLock lockForTempDirs $ do @@ -511,7 +489,7 @@ runSessionWithServerInTmpDirCont :: (FilePath -> Session a) -> IO a runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = runSessionWithTestConfig (mkTestConfig "" plugins) - {testLspConfig=conf, testConfigSession=sessConf, testConfigCaps=caps, testFileTree=Just tree, testDisableKick=disableKick} + {testLspConfig=conf, testConfigSession=sessConf, testConfigCaps=caps, testFileTree=Right tree, testDisableKick=disableKick} act runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a @@ -520,8 +498,7 @@ runSessionWithServer config plugin fp act = instance Default (TestConfig b) where def = TestConfig { - testConfigRoot = "", - testFileTree = Nothing, + testFileTree = Left "", testShiftRoot = False, testDisableKick = False, testDisableDefaultPlugin = False, @@ -534,8 +511,7 @@ instance Default (TestConfig b) where mkTestConfig :: FilePath -> PluginTestDescriptor b -> TestConfig b mkTestConfig fp pd = TestConfig { - testConfigRoot = fp, - testFileTree = Nothing, + testFileTree = Left fp, testShiftRoot = False, testDisableKick = False, testDisableDefaultPlugin = False, @@ -680,10 +656,8 @@ lockForTempDirs = unsafePerformIO newLock data TestConfig b = TestConfig { - testConfigRoot :: FilePath - -- ^ Root directory of the test project - , testFileTree :: Maybe VirtualFileTree - -- ^ Virtual file tree to be used for the test + testFileTree :: Either FilePath VirtualFileTree + -- ^ The file tree to use for the test, either a directory or a virtual file tree , testShiftRoot :: Bool -- ^ Whether to shift the root directory to the test project root , testDisableKick :: Bool @@ -729,11 +703,10 @@ runSessionWithTestConfig TestConfig{..} session = if testShiftRoot then withLock lock $ keepCurrentDirectory $ setCurrentDirectory shiftTarget >> f else f - runSessionInVFS Nothing act = do + runSessionInVFS (Left testConfigRoot) act = do root <- makeAbsolute testConfigRoot act root - runSessionInVFS (Just vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) - -- testingArgs :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments + runSessionInVFS (Right vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) testingArgs prjRoot recorder plugins = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments prjRoot recorder plugins diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 14f3e6f28f..3fede79407 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -119,7 +119,7 @@ suggestionsTests = , testCase "falls back to pre 3.8 code actions" $ runSessionWithTestConfig def { testConfigCaps = noLiteralCaps, - testConfigRoot = testDir, + testFileTree = Left testDir, testPluginDescriptor = hlintPlugin, testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 8f5e4836cd..490de75e40 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3753,7 +3753,7 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a runInDir dir act = runSessionWithTestConfig def - {testConfigRoot=dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} + {testFileTree=Left dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} $ const act lspTestCaps :: ClientCapabilities diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 5ebb748f40..b19be751aa 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -147,7 +147,7 @@ expectRenameError doc pos newName = do runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout . runSessionWithTestConfig def - {testConfigRoot=testDataDir subdir, + {testFileTree= Left $ testDataDir subdir, testPluginDescriptor=renamePlugin, testConfigCaps=codeActionNoResolveCaps} . const diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 5e523a89fe..ea99cb3482 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -142,7 +142,7 @@ semanticTokensConfigTest = ignoreConfigurationRequests = False } , testConfigCaps = fullCaps - , testFileTree = Just fs + , testFileTree = Right fs , testLspConfig = mkSemanticConfig funcVar } $ const $ do From 9882ede4a0a2fb637eb2ac070572c4aa4eba23dc Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 10:04:37 +0800 Subject: [PATCH 31/96] update doc --- ghcide/test/exe/DiagnosticTests.hs | 15 ++++--- hls-test-utils/src/Test/Hls.hs | 68 +++++++++++------------------- 2 files changed, 34 insertions(+), 49 deletions(-) diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 172c9f6742..ec368d5d27 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -36,12 +36,10 @@ import Control.Monad.Extra (whenJust) import Data.Default (def) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import System.Time.Extra -import Test.Hls (TestConfig (testConfigCaps, testLspConfig, testPluginDescriptor), - runSessionWithServerInTmpDirCont, +import Test.Hls (TestConfig (testConfigCaps, testDisableKick, testFileTree, testPluginDescriptor), runSessionWithTestConfig, waitForProgressBegin) -import Test.Hls.FileSystem (directCradle, file, text, - toAbsFp) +import Test.Hls.FileSystem (directCradle, file, text) import Test.Tasty import Test.Tasty.HUnit @@ -581,8 +579,13 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r expectNoMoreDiagnostics 0.5 where - -- similar to run except it disables kick - runTestNoKick s = runSessionWithServerInTmpDirCont True dummyPlugin def def def (mkIdeTestFs []) (const s) + runTestNoKick s = + runSessionWithTestConfig def { + testPluginDescriptor = dummyPlugin + , testFileTree = Right (mkIdeTestFs []) + , testDisableKick = True + } $ const s + typeCheck doc = do WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool "The file should typecheck" ideResultSuccess diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index b88847ec02..d1d3265f00 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -31,8 +31,6 @@ module Test.Hls -- * Running HLS for integration tests runSessionWithServer, runSessionWithServerInTmpDir, - -- continuation version that take a FileSystem - runSessionWithServerInTmpDirCont, runSessionWithTestConfig, -- * Helpful re-exports PluginDescriptor, @@ -423,8 +421,9 @@ initializeTestRecorder envVars = do -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir config plugin tree act = - runSessionWithServerInTmpDirCont False plugin config def fullCaps tree (const act) +runSessionWithServerInTmpDir config plugin tree act = runSessionWithTestConfig def + {testLspConfig=config, testPluginDescriptor = plugin, testFileTree=Right tree} + (const act) runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) -> IO a runWithLockInTempDir tree act = withLock lockForTempDirs $ do @@ -453,44 +452,6 @@ runWithLockInTempDir tree act = withLock lockForTempDirs $ do fs <- FS.materialiseVFT tmpDir tree act fs --- | Host a server, and run a test session on it. --- --- Creates a temporary directory, and materializes the VirtualFileTree --- in the temporary directory. --- --- To debug test cases and verify the file system is correctly set up, --- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. --- Further, we log the temporary directory location on startup. To view --- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. --- --- Example invocation to debug test cases: --- --- @ --- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test --- @ --- --- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. --- --- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. --- --- Note: cwd will be shifted into a temporary directory in @Session a@ -runSessionWithServerInTmpDirCont :: - Pretty b => - -- | whether we disable the kick action or not - Bool -> - -- | Plugins to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - (FilePath -> Session a) -> IO a -runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = - runSessionWithTestConfig (mkTestConfig "" plugins) - {testLspConfig=conf, testConfigSession=sessConf, testConfigCaps=caps, testFileTree=Right tree, testDisableKick=disableKick} - act runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = @@ -658,8 +619,26 @@ data TestConfig b = TestConfig { testFileTree :: Either FilePath VirtualFileTree -- ^ The file tree to use for the test, either a directory or a virtual file tree + + -- if using a virtual file tree, + -- Creates a temporary directory, and materializes the VirtualFileTree + -- in the temporary directory. + -- + -- To debug test cases and verify the file system is correctly set up, + -- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. + -- Further, we log the temporary directory location on startup. To view + -- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. + -- Example invocation to debug test cases: + -- + -- @ + -- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test + -- @ + -- + -- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. + -- + -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. , testShiftRoot :: Bool - -- ^ Whether to shift the root directory to the test project root + -- ^ Whether to shift the current directory to the root of the project , testDisableKick :: Bool -- ^ Whether to disable the kick action , testDisableDefaultPlugin :: Bool @@ -674,6 +653,9 @@ data TestConfig b = TestConfig -- ^ Client capabilities } + +-- | Host a server, and run a test session on it. +-- For detail of the test configuration, see 'TestConfig' runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a runSessionWithTestConfig TestConfig{..} session = runSessionInVFS testFileTree $ \root -> shiftRoot root $ do From fc745c9d24f29723f324f5f521bf6cde9b2949ac Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 10:18:00 +0800 Subject: [PATCH 32/96] clean up consultCradle --- ghcide/session-loader/Development/IDE/Session.hs | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 79334e72d3..b90785afee 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -639,23 +639,18 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog - when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml rootDir - -- TODO: Why are we repeating the same command we have on line 646? - let lfp = makeRelative rootDir cfp - when optTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) - <> " (for " <> T.pack lfp <> ")" + <> " (for " <> T.pack lfpLog <> ")" eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do - addTag "file" lfp + addTag "file" lfpLog old_files <- readIORef cradle_files res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files addTag "result" (show res) From 9eb37632e12f1dd793067eb08ae59526716f8c3a Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 10:24:36 +0800 Subject: [PATCH 33/96] lift toAbsolute --- ghcide/session-loader/Development/IDE/Session.hs | 5 +---- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 5 +---- ghcide/test/exe/ReferenceTests.hs | 6 +----- hls-plugin-api/src/Ide/PluginUtils.hs | 10 ++++++++++ .../src/Ide/Plugin/ModuleName.hs | 5 +---- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 5 ----- 6 files changed, 14 insertions(+), 22 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index b90785afee..b410897db0 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -127,6 +127,7 @@ import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State +import Ide.PluginUtils (toAbsolute) #endif data Log @@ -437,10 +438,6 @@ getHieDbLoc dir = do loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def -toAbsolute :: FilePath -> FilePath -> FilePath -toAbsolute dir file - | isAbsolute file = file - | otherwise = dir file loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let toAbsolutePath = toAbsolute rootDir diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index d6760071f4..ddd5a2e214 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -28,6 +28,7 @@ import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import Ide.PluginUtils (toAbsolute) import OpenTelemetry.Eventlog (withSpan) import System.FilePath @@ -57,10 +58,6 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv } update <$> Unique.newUnique -toAbsolute :: FilePath -> FilePath -> FilePath -toAbsolute root path - | isAbsolute path = path - | otherwise = root path -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEq root cradlePath hscEnv0 deps = do diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 729e919541..a1d6d8a0f7 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -26,6 +26,7 @@ import qualified Data.Aeson as A import Data.Default (def) import Data.Tuple.Extra import GHC.TypeLits (symbolVal) +import Ide.PluginUtils (toAbsolute) import Ide.Types import System.FilePath (isAbsolute, ()) import Test.Hls (FromServerMessage' (..), @@ -204,11 +205,6 @@ referenceTest name loc includeDeclaration expected = type SymbolLocation = (FilePath, UInt, UInt) -toAbsolute :: FilePath -> FilePath -> FilePath -toAbsolute root path - | isAbsolute path = path - | otherwise = root path - expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion expectSameLocations rootDir actual expected = do let actual' = diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index a5f8d7ba54..9f365eeb35 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -32,6 +32,8 @@ module Ide.PluginUtils usePropertyLsp, -- * Escape unescape, + -- * toAbsolute + toAbsolute ) where @@ -50,6 +52,7 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Server +import System.FilePath (isAbsolute, ()) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as P @@ -316,3 +319,10 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) inside' = concatMap f inside pure $ "\"" <> inside' <> "\"" + +-- --------------------------------------------------------------------- + +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute dir file + | isAbsolute file = file + | otherwise = dir file diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index f4df5adb9c..72941c2317 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -53,6 +53,7 @@ import Development.IDE.GHC.Compat (GenLocated (L), pm_parsed_source, unLoc) import Ide.Logger (Pretty (..)) import Ide.Plugin.Error +import Ide.PluginUtils (toAbsolute) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -133,10 +134,6 @@ action recorder state uri = do in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code] _ -> pure [] -toAbsolute :: FilePath -> FilePath -> FilePath -toAbsolute root path - | isAbsolute path = path - | otherwise = root path -- | Possible module names, as derived by the position of the module in the -- source directories. There may be more than one possible name, if the source -- directories are nested inside each other. diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index e5eff62b15..8d532d7360 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -760,11 +760,6 @@ reuseParsedModule state f = do (fixities, pm') <- fixFixities state f (fixAnns pm) return (fixities, pm') -toAbsolute :: FilePath -> FilePath -> FilePath -toAbsolute dir file - | isAbsolute file = file - | otherwise = dir file - getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t From 80bd4de8d086a692a1505be75b6cd8f2d9105676 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 10:32:52 +0800 Subject: [PATCH 34/96] clean up --- hls-test-utils/src/Test/Hls.hs | 22 +++++----------------- plugins/hls-hlint-plugin/test/Main.hs | 21 ++++++++++++++++++--- plugins/hls-stan-plugin/test/Main.hs | 7 ++++++- test/functional/Config.hs | 5 +++-- 4 files changed, 32 insertions(+), 23 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index d1d3265f00..ee05cac155 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -58,7 +58,6 @@ module Test.Hls Recorder, Priority(..), TestConfig(..), - mkTestConfig, ) where @@ -455,7 +454,11 @@ runWithLockInTempDir tree act = withLock lockForTempDirs $ do runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = - runSessionWithTestConfig (mkTestConfig fp plugin){testLspConfig=config} (const act) + runSessionWithTestConfig def { + testLspConfig=config + , testPluginDescriptor=plugin + , testFileTree = Left fp + } (const act) instance Default (TestConfig b) where def = TestConfig { @@ -469,21 +472,6 @@ instance Default (TestConfig b) where testConfigCaps = fullCaps } - -mkTestConfig :: FilePath -> PluginTestDescriptor b -> TestConfig b -mkTestConfig fp pd = TestConfig { - testFileTree = Left fp, - testShiftRoot = False, - testDisableKick = False, - testDisableDefaultPlugin = False, - testPluginDescriptor = pd, - testLspConfig = def, - testConfigSession = def, - testConfigCaps = fullCaps -} - - - -- | Setup the test environment for isolated tests. -- -- This creates a directory in the temporary directory that will be diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 3fede79407..be2c172183 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -347,7 +347,12 @@ testDir = "plugins/hls-hlint-plugin/test/testdata" runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir = failIfSessionTimeout . - runSessionWithTestConfig (mkTestConfig (testDir subdir) hlintPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + runSessionWithTestConfig def + {testConfigCaps=codeActionNoResolveCaps + , testShiftRoot=True + , testFileTree=Left (testDir subdir) + , testPluginDescriptor=hlintPlugin + } . const noHlintDiagnostics :: [Diagnostic] -> Assertion @@ -429,7 +434,12 @@ goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithTestConfig (mkTestConfig testDir hlintPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + goldenWithTestConfig def + {testConfigCaps=codeActionNoResolveCaps + , testShiftRoot=True + , testPluginDescriptor=hlintPlugin + , testFileTree=Left testDir + } testName testDir path "expected" "hs" @@ -452,5 +462,10 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithTestConfig (mkTestConfig testDir hlintPlugin){testConfigCaps=codeActionResolveCaps, testShiftRoot=True} + goldenWithTestConfig def + {testConfigCaps=codeActionResolveCaps + , testShiftRoot=True + , testPluginDescriptor=hlintPlugin + , testFileTree=Left testDir + } testName testDir path "expected" "hs" diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index 5f507989d7..bd7798d8da 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -76,5 +76,10 @@ stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" runStanSession :: FilePath -> Session a -> IO a runStanSession subdir = failIfSessionTimeout - . runSessionWithTestConfig (mkTestConfig (testDir subdir) stanPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + . runSessionWithTestConfig def{ + testConfigCaps=codeActionNoResolveCaps + , testShiftRoot=True + , testPluginDescriptor=stanPlugin + , testFileTree=Left (testDir subdir) + } . const diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 1db1601d1b..df3bd3f289 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -69,8 +69,9 @@ genericConfigTests = testGroup "generic plugin config" runConfigSession subdir session = do failIfSessionTimeout $ - runSessionWithTestConfig (mkTestConfig ("test/testdata" subdir) plugin) - {testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True} (const session) + runSessionWithTestConfig def + {testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True + , testPluginDescriptor=plugin, testFileTree=Left ("test/testdata" subdir)} (const session) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics From 836c1b72f9c33c497b68c18d42a2cf621dbce5c5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 10:46:06 +0800 Subject: [PATCH 35/96] fix --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- ghcide/test/exe/Config.hs | 2 +- ghcide/test/exe/DependentFileTest.hs | 2 +- ghcide/test/exe/DiagnosticTests.hs | 4 ++-- hls-test-utils/src/Test/Hls.hs | 15 +++++++-------- plugins/hls-hlint-plugin/test/Main.hs | 8 ++++---- plugins/hls-refactor-plugin/test/Main.hs | 2 +- plugins/hls-rename-plugin/test/Main.hs | 2 +- .../test/SemanticTokensTest.hs | 2 +- plugins/hls-stan-plugin/test/Main.hs | 2 +- test/functional/Config.hs | 2 +- 11 files changed, 21 insertions(+), 22 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index b410897db0..99eadff1f1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -111,6 +111,7 @@ import Development.IDE.Types.Shake (WithHieDb, toNoFileKey) import HieDb.Create import HieDb.Types import HieDb.Utils +import Ide.PluginUtils (toAbsolute) import qualified System.Random as Random import System.Random (RandomGen) @@ -127,7 +128,6 @@ import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State -import Ide.PluginUtils (toAbsolute) #endif data Log diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 1313d2641e..6c7fdd66c4 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -51,7 +51,7 @@ runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a -runWithDummyPlugin' fs = runSessionWithTestConfig def { testPluginDescriptor = dummyPlugin, testFileTree = Right fs } +runWithDummyPlugin' fs = runSessionWithTestConfig def { testPluginDescriptor = dummyPlugin, testDirLocation = Right fs } testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index f4887d56a9..fe67647155 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -21,7 +21,7 @@ tests :: TestTree tests = testGroup "addDependentFile" [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def {testShiftRoot=True - , testFileTree=Right (mkIdeTestFs []) + , testDirLocation=Right (mkIdeTestFs []) , testPluginDescriptor = dummyPlugin } test] ] diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index ec368d5d27..14599f6d4b 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -36,7 +36,7 @@ import Control.Monad.Extra (whenJust) import Data.Default (def) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import System.Time.Extra -import Test.Hls (TestConfig (testConfigCaps, testDisableKick, testFileTree, testPluginDescriptor), +import Test.Hls (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor), runSessionWithTestConfig, waitForProgressBegin) import Test.Hls.FileSystem (directCradle, file, text) @@ -582,7 +582,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r runTestNoKick s = runSessionWithTestConfig def { testPluginDescriptor = dummyPlugin - , testFileTree = Right (mkIdeTestFs []) + , testDirLocation = Right (mkIdeTestFs []) , testDisableKick = True } $ const s diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index ee05cac155..d6f946c6fe 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -200,7 +200,7 @@ goldenWithHaskellAndCaps goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) $ runSessionWithTestConfig def { - testFileTree = Left testDataDir, + testDirLocation = Left testDataDir, testConfigCaps = clientCaps, testLspConfig = config, testPluginDescriptor = plugin @@ -250,7 +250,7 @@ goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc e goldenGitDiff title (vftOriginalRoot tree path <.> desc <.> ext) $ runSessionWithTestConfig def { - testFileTree = Right tree, + testDirLocation = Right tree, testConfigCaps = clientCaps, testLspConfig = config, testPluginDescriptor = plugin @@ -421,7 +421,7 @@ initializeTestRecorder envVars = do -- ------------------------------------------------------------ runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a runSessionWithServerInTmpDir config plugin tree act = runSessionWithTestConfig def - {testLspConfig=config, testPluginDescriptor = plugin, testFileTree=Right tree} + {testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right tree} (const act) runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) -> IO a @@ -451,18 +451,17 @@ runWithLockInTempDir tree act = withLock lockForTempDirs $ do fs <- FS.materialiseVFT tmpDir tree act fs - runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = runSessionWithTestConfig def { testLspConfig=config , testPluginDescriptor=plugin - , testFileTree = Left fp + , testDirLocation = Left fp } (const act) instance Default (TestConfig b) where def = TestConfig { - testFileTree = Left "", + testDirLocation = Left "", testShiftRoot = False, testDisableKick = False, testDisableDefaultPlugin = False, @@ -605,7 +604,7 @@ lockForTempDirs = unsafePerformIO newLock data TestConfig b = TestConfig { - testFileTree :: Either FilePath VirtualFileTree + testDirLocation :: Either FilePath VirtualFileTree -- ^ The file tree to use for the test, either a directory or a virtual file tree -- if using a virtual file tree, @@ -646,7 +645,7 @@ data TestConfig b = TestConfig -- For detail of the test configuration, see 'TestConfig' runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a runSessionWithTestConfig TestConfig{..} session = - runSessionInVFS testFileTree $ \root -> shiftRoot root $ do + runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do (inR, inW) <- createPipe (outR, outW) <- createPipe diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index be2c172183..ef23657f55 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -119,7 +119,7 @@ suggestionsTests = , testCase "falls back to pre 3.8 code actions" $ runSessionWithTestConfig def { testConfigCaps = noLiteralCaps, - testFileTree = Left testDir, + testDirLocation = Left testDir, testPluginDescriptor = hlintPlugin, testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" @@ -350,7 +350,7 @@ runHlintSession subdir = failIfSessionTimeout . runSessionWithTestConfig def {testConfigCaps=codeActionNoResolveCaps , testShiftRoot=True - , testFileTree=Left (testDir subdir) + , testDirLocation=Left (testDir subdir) , testPluginDescriptor=hlintPlugin } . const @@ -438,7 +438,7 @@ setupGoldenHlintTest testName path = {testConfigCaps=codeActionNoResolveCaps , testShiftRoot=True , testPluginDescriptor=hlintPlugin - , testFileTree=Left testDir + , testDirLocation=Left testDir } testName testDir path "expected" "hs" @@ -466,6 +466,6 @@ setupGoldenHlintResolveTest testName path = {testConfigCaps=codeActionResolveCaps , testShiftRoot=True , testPluginDescriptor=hlintPlugin - , testFileTree=Left testDir + , testDirLocation=Left testDir } testName testDir path "expected" "hs" diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 490de75e40..9e2a6951fc 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3753,7 +3753,7 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a runInDir dir act = runSessionWithTestConfig def - {testFileTree=Left dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} + {testDirLocation=Left dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} $ const act lspTestCaps :: ClientCapabilities diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index b19be751aa..0c031be561 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -147,7 +147,7 @@ expectRenameError doc pos newName = do runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout . runSessionWithTestConfig def - {testFileTree= Left $ testDataDir subdir, + {testDirLocation= Left $ testDataDir subdir, testPluginDescriptor=renamePlugin, testConfigCaps=codeActionNoResolveCaps} . const diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index ea99cb3482..31845d8bd0 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -142,7 +142,7 @@ semanticTokensConfigTest = ignoreConfigurationRequests = False } , testConfigCaps = fullCaps - , testFileTree = Right fs + , testDirLocation = Right fs , testLspConfig = mkSemanticConfig funcVar } $ const $ do diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index bd7798d8da..231707d142 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -80,6 +80,6 @@ runStanSession subdir = testConfigCaps=codeActionNoResolveCaps , testShiftRoot=True , testPluginDescriptor=stanPlugin - , testFileTree=Left (testDir subdir) + , testDirLocation=Left (testDir subdir) } . const diff --git a/test/functional/Config.hs b/test/functional/Config.hs index df3bd3f289..a8e51531fd 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -71,7 +71,7 @@ genericConfigTests = testGroup "generic plugin config" failIfSessionTimeout $ runSessionWithTestConfig def {testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True - , testPluginDescriptor=plugin, testFileTree=Left ("test/testdata" subdir)} (const session) + , testPluginDescriptor=plugin, testDirLocation=Left ("test/testdata" subdir)} (const session) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics From faf0cc7d895bd3e48c07f9196558914e5fbf9240 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 11:27:38 +0800 Subject: [PATCH 36/96] shift to the lsp root if the root is not the current directory --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 1ea8dd6a1a..97bca6e5f7 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -198,6 +198,9 @@ handleInit handleInit rootDir recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let rootMaybe = LSP.resRootPath env + -- only shift if lsp root is different from the rootDir + when (rootMaybe /= Just rootDir) $ do + setCurrentDirectory rootDir let root = fromMaybe rootDir rootMaybe dbLoc <- getHieDbLoc root let initConfig = parseConfiguration params From 887f8edbdd87f91f8b91f836e4c60fb01ce5a69e Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 11:34:57 +0800 Subject: [PATCH 37/96] spawn to tmp dir by default --- ghcide/test/exe/DiagnosticTests.hs | 1 + hls-test-utils/src/Test/Hls.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 14599f6d4b..52dbb5068b 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -173,6 +173,7 @@ tests = testGroup "diagnostics" runSessionWithTestConfig def { testPluginDescriptor = dummyPlugin , testConfigCaps = lspTestCapsNoFileWatches + , testDirLocation = Right (mkIdeTestFs []) } $ \tmpDir -> do -- By default lsp-test sends FileWatched notifications for all files, which we don't want diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index d6f946c6fe..b2c26b627a 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -461,7 +461,7 @@ runSessionWithServer config plugin fp act = instance Default (TestConfig b) where def = TestConfig { - testDirLocation = Left "", + testDirLocation = Right $ VirtualFileTree [] "", testShiftRoot = False, testDisableKick = False, testDisableDefaultPlugin = False, From 1320577764b6d317239b9d80ee6fdaa3844703a8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 12:54:17 +0800 Subject: [PATCH 38/96] fix exceptionTests --- ghcide/test/exe/ExceptionTests.hs | 25 +++++++++++++------------ hls-test-utils/src/Test/Hls.hs | 18 ++++++++++++------ 2 files changed, 25 insertions(+), 18 deletions(-) diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index a734e0529c..e035e6dad2 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -29,8 +29,9 @@ import Language.LSP.Protocol.Types hiding import Language.LSP.Test import LogType (Log (..)) import Test.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), - hlsPluginTestRecorder, runSessionWithTestConfig, + testCheckProject, + testConfigSession, waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit @@ -42,17 +43,17 @@ tests = do [ testCase "PluginHandlers" $ do let pluginId = "plugin-handler-exception" plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins _ = pluginDescToIdePlugins $ + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do _ <- liftIO $ throwIO DivideByZero pure (InL []) ] - }] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False + } $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) case lens of Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> @@ -64,15 +65,15 @@ tests = do let pluginId = "command-exception" commandId = CommandId "exception" plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins _ = pluginDescToIdePlugins $ + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginCommands = [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do _ <- liftIO $ throwIO DivideByZero pure (InR Null) ] - }] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=False, testCheckProject=True} $ const $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -87,7 +88,7 @@ tests = do , testCase "Notification Handlers" $ do let pluginId = "notification-exception" plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins _ = pluginDescToIdePlugins $ + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -97,8 +98,8 @@ tests = do [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do pure (InL []) ] - }] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=False, testCheckProject=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -130,7 +131,7 @@ pluginOrderTestCase msg err1 err2 = throwError err2 ] }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index b2c26b627a..ab70e5888e 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -83,6 +83,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState, LoggingColumn (ThreadIdColumn)) +import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), @@ -468,7 +469,8 @@ instance Default (TestConfig b) where testPluginDescriptor = mempty, testLspConfig = def, testConfigSession = def, - testConfigCaps = fullCaps + testConfigCaps = fullCaps, + testCheckProject = False } -- | Setup the test environment for isolated tests. @@ -630,6 +632,8 @@ data TestConfig b = TestConfig -- ^ Whether to disable the kick action , testDisableDefaultPlugin :: Bool -- ^ Whether to disable the default plugin comes with ghcide + , testCheckProject :: Bool + -- ^ Whether to disable the default plugin comes with ghcide , testPluginDescriptor :: PluginTestDescriptor b -- ^ Plugin to load on the server. , testLspConfig :: Config @@ -653,7 +657,7 @@ runSessionWithTestConfig TestConfig{..} session = let plugins = testPluginDescriptor recorder recorderIde <- hlsHelperTestRecorder let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig } - arguments = testingArgs root (cmapWithPrio LogIDEMain recorderIde) plugins + arguments = testingArgs root recorderIde plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) arguments { argsHandleIn = pure inR , argsHandleOut = pure outW } @@ -676,15 +680,17 @@ runSessionWithTestConfig TestConfig{..} session = root <- makeAbsolute testConfigRoot act root runSessionInVFS (Right vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) - testingArgs prjRoot recorder plugins = + testingArgs prjRoot recorderIde plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments prjRoot recorder plugins - argsHlsPlugins' = if testDisableDefaultPlugin then plugins else argsHlsPlugins + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments prjRoot (cmapWithPrio LogIDEMain recorderIde) plugins + argsHlsPlugins' = if testDisableDefaultPlugin + then plugins + else argsHlsPlugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins' ++ [Test.blockCommandDescriptor "block-command", Test.plugin] ideOptions config sessionLoader = (argsIdeOptions config sessionLoader){ optTesting = IdeTesting True - , optCheckProject = pure False + , optCheckProject = pure testCheckProject } in arguments From 88262561d12a6f8aea777ae65ef2fe0483bc7a27 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 13:08:57 +0800 Subject: [PATCH 39/96] clear up --- ghcide/test/exe/ExceptionTests.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index e035e6dad2..6c08f7ecba 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -73,7 +73,7 @@ tests = do pure (InR Null) ] }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=False, testCheckProject=True} $ const $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -99,7 +99,7 @@ tests = do pure (InL []) ] }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=False, testCheckProject=True} $ const $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -131,7 +131,7 @@ pluginOrderTestCase msg err1 err2 = throwError err2 ] }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=True} $ const $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) From 53cfa5f7e939384711c58de331ea0f3d2c4365f7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 13:13:29 +0800 Subject: [PATCH 40/96] migrate THTests --- ghcide/test/exe/THTests.hs | 12 ++++++------ ghcide/test/exe/TestUtils.hs | 15 --------------- ghcide/test/exe/UnitTests.hs | 1 - 3 files changed, 6 insertions(+), 22 deletions(-) diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs index 038de5ce21..1075253c0a 100644 --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -1,6 +1,7 @@ module THTests (tests) where +import Config import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Development.IDE.GHC.Util @@ -16,14 +17,13 @@ import Test.Hls (waitForAllProgressDone, waitForProgressBegin) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "TemplateHaskell" [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "load" $ do + testWithDummyPluginEmpty "load" $ do let sourceA = T.unlines [ "{-# LANGUAGE PackageImports #-}", @@ -46,7 +46,7 @@ tests = _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "newtype-closure" $ do + , testWithDummyPluginEmpty "newtype-closure" $ do let sourceA = T.unlines [ "{-# LANGUAGE DeriveDataTypeable #-}" @@ -70,11 +70,11 @@ tests = , thReloadingTest False , thLoadingTest , thCoreTest - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + , thReloadingTest True -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "findsTHIdentifiers" $ do + , thLinkingTest True + , testWithDummyPluginEmpty "findsTHIdentifiers" $ do let sourceA = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 0b9ce03eb2..87c129ba2f 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -195,18 +195,3 @@ copyTestDataFiles dir prefix = do withLongTimeout :: IO a -> IO a withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - withTempDir $ \dir -> do - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps dir session diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index a6ba0abd01..1e8ac4214a 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -88,7 +88,6 @@ tests recorder = do ] ++ Ghcide.descriptors recorder priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} - -- testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone From 5dc3035f44b519060d4708371e2691fa68ebb21f Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 14:12:15 +0800 Subject: [PATCH 41/96] fix Retrie --- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 8d532d7360..b88e79d2b0 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -129,7 +129,6 @@ import Retrie.SYB (everything, extQ, listify, mkQ) import Retrie.Types import Retrie.Universe (Universe) -import System.FilePath (isAbsolute, ()) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual From f3cd2e22e21d30c3403fe44a9844c754fb422de8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 15:51:01 +0800 Subject: [PATCH 42/96] migrate ClientSettingsTests CodeLensTests CPPTests CradleTests --- ghcide/test/exe/CPPTests.hs | 6 ++-- ghcide/test/exe/ClientSettingsTests.hs | 6 ++-- ghcide/test/exe/CodeLensTests.hs | 8 ++--- ghcide/test/exe/Config.hs | 34 +++++++++++++++++++-- ghcide/test/exe/CradleTests.hs | 17 ++++++----- ghcide/test/exe/GarbageCollectionTests.hs | 10 +++---- ghcide/test/exe/InitializeResponseTests.hs | 2 +- hls-test-utils/hls-test-utils.cabal | 1 + hls-test-utils/src/Test/Hls.hs | 35 ++++++++++++++++++---- 9 files changed, 88 insertions(+), 31 deletions(-) diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs index da9f564fe4..91a59adc76 100644 --- a/ghcide/test/exe/CPPTests.hs +++ b/ghcide/test/exe/CPPTests.hs @@ -9,14 +9,14 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test -- import Test.QuickCheck.Instances () +import Config import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + [ testCase "cpp-error" $ do let content = T.unlines [ "{-# LANGUAGE CPP #-}", @@ -32,7 +32,7 @@ tests = let _ = e :: HUnitFailure run $ expectError content (2, 1) ) - , testSessionWait "cpp-ghcide" $ do + , testWithDummyPluginEmpty "cpp-ghcide" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines ["{-# LANGUAGE CPP #-}" ,"main =" diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs index 6d964d3542..698e0af165 100644 --- a/ghcide/test/exe/ClientSettingsTests.hs +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} module ClientSettingsTests (tests) where +import Config (lspTestCaps, testWithConfig) import Control.Applicative.Combinators import Control.Monad import Data.Aeson (toJSON) @@ -14,13 +15,14 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls (waitForProgressDone) +import Test.Hls (testConfigCaps, + waitForProgressDone) import Test.Tasty import TestUtils tests :: TestTree tests = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do + [ testWithConfig "ghcide restarts shake session on config changes" def {testConfigCaps = lspTestCaps} $ do setIgnoringLogNotifications False void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 6bebeda002..c5f320f5c7 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -2,6 +2,7 @@ module CodeLensTests (tests) where +import Config import Control.Applicative.Combinators import Control.Lens ((^.)) import Control.Monad (void) @@ -18,10 +19,9 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls (waitForProgressDone) +import Test.Hls (mkRange, waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "code lenses" @@ -46,7 +46,7 @@ addSigLensesTests = after' enableGHCWarnings exported (def, sig) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]] - sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do + sigSession testName enableGHCWarnings waitForDiags mode exported def others = testWithDummyPluginEmpty testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others setConfigSection "haskell" (createConfig mode) @@ -100,7 +100,7 @@ addSigLensesTests = [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) [] , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] ] - , testSession "keep stale lens" $ do + , testWithDummyPluginEmpty "keep stale lens" $ do let content = T.unlines [ "module Stale where" , "f = _" diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 6c7fdd66c4..8297436781 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -11,28 +11,34 @@ module Config( , testWithDummyPluginEmpty , testWithDummyPlugin' , testWithDummyPluginEmpty' + , testWithConfig + , testWithExtraFiles , runWithExtraFiles , runInDir - , testWithExtraFiles + , run - -- * utilities for testing definition and hover + -- * utilities for testing , Expect(..) , pattern R , mkR , checkDefs , mkL + , withLongTimeout , lspTestCaps , lspTestCapsNoFileWatches ) where +import Control.Exception (bracket_) import Control.Lens.Setter ((.~)) import Data.Foldable (traverse_) import Data.Function ((&)) import qualified Data.Text as T +import Development.IDE (Pretty) import Development.IDE.Test (canonicalizeUri) import Ide.Types (defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types (Null (..)) +import System.Environment.Blank (setEnv, unsetEnv) import System.FilePath (()) import Test.Hls import qualified Test.Hls.FileSystem as FS @@ -50,8 +56,16 @@ dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dum runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin +testWithConfig :: String -> TestConfig () -> Session () -> TestTree +testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s + runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a -runWithDummyPlugin' fs = runSessionWithTestConfig def { testPluginDescriptor = dummyPlugin, testDirLocation = Right fs } +runWithDummyPlugin' fs = runSessionWithTestConfig def { + testPluginDescriptor = dummyPlugin + , testDirLocation = Right fs + , testConfigCaps = lspTestCaps + , testShiftRoot = True + } testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const @@ -76,6 +90,17 @@ testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFil runInDir :: FilePath -> Session a -> IO a runInDir fs = runSessionWithServer def dummyPlugin fs +testSession' :: TestName -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + +run :: Session a -> IO a +run = runSessionWithTestConfig def + {testDirLocation=Right (mkIdeTestFs []), testPluginDescriptor=dummyPlugin} + . const + +run' :: (FilePath -> Session a) -> IO a +run' = runSessionWithTestConfig def {testDirLocation=Right (mkIdeTestFs []), testPluginDescriptor=dummyPlugin} + pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') @@ -138,3 +163,6 @@ lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) N lspTestCapsNoFileWatches :: ClientCapabilities lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index 196bea95e6..ca922d53cc 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -25,13 +25,14 @@ import Language.LSP.Test import System.FilePath import System.IO.Extra hiding (withTempDir) -- import Test.QuickCheck.Instances () +import Config import Config (checkDefs, mkL) import Control.Lens ((^.)) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import GHC.TypeLits (symbolVal) +import Test.Hls (ignoreForGhcVersions) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree @@ -40,17 +41,17 @@ tests = testGroup "cradle" ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] ,testGroup "multi" (multiTests "multi") - ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" $ testGroup "multi-unit" (multiTests "multi-unit") ,testGroup "sub-directory" [simpleSubDirectoryTest] - ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" $ testGroup "multi-unit-rexport" [multiRexportTest] ] loadCradleOnlyonce :: TestTree loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct + [ testWithDummyPluginEmpty' "implicit" implicit + , testWithDummyPluginEmpty' "direct" direct ] where direct dir = do @@ -70,7 +71,7 @@ loadCradleOnlyonce = testGroup "load cradle only once" liftIO $ length msgs @?= 0 retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do +retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do -- The false cradle always fails let hieContents = "cradle: {bios: {shell: \"false\"}}" hiePath = dir "hie.yaml" @@ -124,7 +125,7 @@ multiTestName :: FilePath -> String -> String multiTestName dir name = "simple-" ++ dir ++ "-" ++ name simpleMultiTest :: FilePath -> TestTree -simpleMultiTest variant = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \dir -> do +simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" adoc <- openDoc aPath "haskell" @@ -201,7 +202,7 @@ multiRexportTest = expectNoMoreDiagnostics 0.5 sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' +sessionDepsArePickedUp = testWithDummyPluginEmpty' "session-deps-are-picked-up" $ \dir -> do liftIO $ diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs index 31b705c0f3..8c0c428c1a 100644 --- a/ghcide/test/exe/GarbageCollectionTests.hs +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -1,5 +1,6 @@ module GarbageCollectionTests (tests) where +import Config (testWithDummyPluginEmpty') import Control.Monad.IO.Class (liftIO) import qualified Data.Set as Set import qualified Data.Text as T @@ -13,20 +14,19 @@ import Language.LSP.Test import System.FilePath import Test.Tasty import Test.Tasty.HUnit -import TestUtils import Text.Printf (printf) tests :: TestTree tests = testGroup "garbage collection" [ testGroup "dirty keys" - [ testSession' "are collected" $ \dir -> do + [ testWithDummyPluginEmpty' "are collected" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" doc <- generateGarbage "A" dir closeDoc doc garbage <- waitForGC liftIO $ assertBool "no garbage was found" $ not $ null garbage - , testSession' "are deleted from the state" $ \dir -> do + , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir keys0 <- getStoredKeys @@ -36,7 +36,7 @@ tests = testGroup "garbage collection" keys1 <- getStoredKeys liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) - , testSession' "are not regenerated unless needed" $ \dir -> do + , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" docA <- generateGarbage "A" dir _docB <- generateGarbage "B" dir @@ -57,7 +57,7 @@ tests = testGroup "garbage collection" Set.intersection (Set.fromList garbage) (Set.fromList keysB) liftIO $ regeneratedKeys @?= mempty - , testSession' "regenerate successfully" $ \dir -> do + , testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir closeDoc docA diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 16e4e4b6f4..6192a8aeed 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -87,7 +87,7 @@ tests = withResource acquire release tests where innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" acquire :: IO (TResponseMessage Method_Initialize) - acquire = runWithDummyPlugin (mkIdeTestFs []) initializeResponse + acquire = run initializeResponse release :: TResponseMessage Method_Initialize -> IO () release = mempty diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index cebf06629b..f284f8088d 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -46,6 +46,7 @@ library , ghcide == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens + , lsp , lsp-test ^>=0.17 , lsp-types ^>=2.2 , safe-exceptions diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index ab70e5888e..7865df14d3 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -5,6 +5,8 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -82,7 +84,9 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState, - LoggingColumn (ThreadIdColumn)) + LoggingColumn (ThreadIdColumn), + defaultLayoutOptions, + layoutPretty, renderStrict) import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as IDEMain @@ -100,12 +104,16 @@ import Ide.Logger (Pretty (pretty), logWith, makeDefaultStderrRecorder, (<+>)) +import qualified Ide.Logger as Logger +import Ide.Plugin.Properties ((&)) import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types hiding (Null) +import qualified Language.LSP.Server as LSP import Language.LSP.Test import Prelude hiding (log) import System.Directory (canonicalizePath, @@ -407,6 +415,7 @@ hlsPluginTestRecorder = initializeTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "H initializeTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a)) initializeTestRecorder envVars = do docWithPriorityRecorder <- makeDefaultStderrRecorder (Just $ ThreadIdColumn : defaultLoggingColumns) + -- lspClientLogRecorder -- There are potentially multiple environment variables that enable this logger definedEnvVars <- forM envVars (fmap (fromMaybe "0") . lookupEnv) let logStdErr = any (/= "0") definedEnvVars @@ -421,7 +430,8 @@ initializeTestRecorder envVars = do -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir config plugin tree act = runSessionWithTestConfig def +runSessionWithServerInTmpDir config plugin tree act = + runSessionWithTestConfig def {testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right tree} (const act) @@ -645,6 +655,13 @@ data TestConfig b = TestConfig } +wrapClientLogger :: Pretty a => Recorder (WithPriority a) -> + IO (Recorder (WithPriority a), LSP.LanguageContextEnv Config -> IO ()) +wrapClientLogger logger = do + (lspLogRecorder', cb1) <- Logger.withBacklog Logger.lspClientLogRecorder + let lspLogRecorder = cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions. pretty) lspLogRecorder' + return (lspLogRecorder <> logger, cb1) + -- | Host a server, and run a test session on it. -- For detail of the test configuration, see 'TestConfig' runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a @@ -653,9 +670,17 @@ runSessionWithTestConfig TestConfig{..} session = (inR, inW) <- createPipe (outR, outW) <- createPipe - recorder <- hlsPluginTestRecorder - let plugins = testPluginDescriptor recorder - recorderIde <- hlsHelperTestRecorder + (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder + (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder + -- This plugin just installs a handler for the `initialized` notification, which then + -- picks up the LSP environment and feeds it to our recorders + let lspRecorderPlugin = pluginDescToIdePlugins [(defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin") + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do + env <- LSP.getLspEnv + liftIO $ (cb1 <> cb2) env + }] + + let plugins = testPluginDescriptor recorder <> lspRecorderPlugin let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig } arguments = testingArgs root recorderIde plugins server <- async $ From 9298cc0d1db54082048cc5a17c1b86f0409b77ff Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 16 May 2024 22:31:18 +0800 Subject: [PATCH 43/96] add comment --- ghcide/src/Development/IDE/Core/Rules.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 55094bca47..291938d9de 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -713,6 +713,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + -- loading is always returning a absolute path now (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file -- add the deps to the Shake graph From 1bb8c51bbcf0d33768e69725801225a17faf0a94 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 19 May 2024 10:36:06 +0800 Subject: [PATCH 44/96] move recorder first --- exe/Wrapper.hs | 2 +- ghcide/exe/Main.hs | 4 ++-- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 14 +++++++------- ghcide/src/Development/IDE/Main.hs | 12 ++++++------ hls-test-utils/src/Test/Hls.hs | 2 +- src/Ide/Main.hs | 4 ++-- 6 files changed, 19 insertions(+), 19 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 0309840c97..d4b7f8f9fb 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -270,7 +270,7 @@ newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a } launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO () launchErrorLSP recorder errorMsg = do cwd <- getCurrentDirectory - let defaultArguments = Main.defaultArguments cwd (cmapWithPrio pretty recorder) (IdePlugins []) + let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) cwd (IdePlugins []) inH <- Main.argsHandleIn defaultArguments diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 959cd8c9d2..80913da190 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -112,8 +112,8 @@ main = withTelemetryRecorder $ \telemetryRecorder -> do let arguments = if argsTesting - then IDEMain.testing argsCwd (cmapWithPrio LogIDEMain recorder) hlsPlugins - else IDEMain.defaultArguments argsCwd (cmapWithPrio LogIDEMain recorder) hlsPlugins + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { IDEMain.argsProjectRoot = argsCwd diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 97bca6e5f7..e3c8cb58bd 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -125,8 +125,8 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh setupLSP :: forall config err. - FilePath -- ^ root directory - -> Recorder (WithPriority Log) + Recorder (WithPriority Log) + -> FilePath -- ^ root directory -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) @@ -134,7 +134,7 @@ setupLSP :: -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP root recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do +setupLSP recorder root getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan @@ -177,7 +177,7 @@ setupLSP root recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit root recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let doInitialize = handleInit recorder root getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO @@ -185,8 +185,8 @@ setupLSP root recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do handleInit - :: FilePath - -> Recorder (WithPriority Log) + :: Recorder (WithPriority Log) + -> FilePath -> (FilePath -> IO FilePath) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () @@ -195,7 +195,7 @@ handleInit -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit rootDir recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit recorder rootDir getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let rootMaybe = LSP.resRootPath env -- only shift if lsp root is different from the rootDir diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a41d9199e0..649f6e422e 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -226,8 +226,8 @@ data Arguments = Arguments , argsDisableKick :: Bool -- ^ flag to disable kick used for testing } -defaultArguments :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -defaultArguments fp recorder plugins = Arguments +defaultArguments :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +defaultArguments recorder fp plugins = Arguments { argsProjectRoot = fp , argCommand = LSP , argsRules = mainRule (cmapWithPrio LogRules recorder) def @@ -263,11 +263,11 @@ defaultArguments fp recorder plugins = Arguments } -testing :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -testing fp recorder plugins = +testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +testing recorder fp plugins = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = - defaultArguments fp recorder plugins + defaultArguments recorder fp plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -357,7 +357,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putMVar ideStateVar ide pure ide - let setup = setupLSP argsProjectRoot (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState -- See Note [Client configuration in Rules] onConfigChange cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 7865df14d3..fd0113fa7f 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -707,7 +707,7 @@ runSessionWithTestConfig TestConfig{..} session = runSessionInVFS (Right vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) testingArgs prjRoot recorderIde plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments prjRoot (cmapWithPrio LogIDEMain recorderIde) plugins + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot plugins argsHlsPlugins' = if testDisableDefaultPlugin then plugins else argsHlsPlugins diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 30ff1a90a4..cbe3f33bb3 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -130,8 +130,8 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryRec when (isLSP argsCommand) $ do log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) - let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) dir - (cmapWithPrio LogIDEMain recorder) idePlugins + let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) + (cmapWithPrio LogIDEMain recorder) dir idePlugins let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty From bb4500328bb8bb80e185a11a0717e6faf4abf14a Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 19 May 2024 10:42:37 +0800 Subject: [PATCH 45/96] rename --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e3c8cb58bd..528adbbf09 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -134,7 +134,7 @@ setupLSP :: -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder root getHieDbLoc userHandlers getIdeState clientMsgVar = do +setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan @@ -177,7 +177,7 @@ setupLSP recorder root getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder root getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO @@ -195,13 +195,13 @@ handleInit -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder rootDir getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let rootMaybe = LSP.resRootPath env -- only shift if lsp root is different from the rootDir - when (rootMaybe /= Just rootDir) $ do - setCurrentDirectory rootDir - let root = fromMaybe rootDir rootMaybe + root <- case rootMaybe of + Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot + _ -> pure defaultRoot dbLoc <- getHieDbLoc root let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig From 166bbe9bfdfd866f66df4f9f97a03c6ffdd054f7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 19 May 2024 11:51:01 +0800 Subject: [PATCH 46/96] clean up --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 528adbbf09..18d6e213fd 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -197,9 +197,8 @@ handleInit -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - let rootMaybe = LSP.resRootPath env -- only shift if lsp root is different from the rootDir - root <- case rootMaybe of + root <- case LSP.resRootPath env of Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot _ -> pure defaultRoot dbLoc <- getHieDbLoc root From 48bc29b6c81ebd186f3697b17ae76e59112f4c41 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 10:43:41 +0800 Subject: [PATCH 47/96] fix test --- hls-test-utils/src/Test/Hls.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index fd0113fa7f..ad0dec8342 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -707,7 +707,7 @@ runSessionWithTestConfig TestConfig{..} session = runSessionInVFS (Right vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) testingArgs prjRoot recorderIde plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot plugins + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot plugins argsHlsPlugins' = if testDisableDefaultPlugin then plugins else argsHlsPlugins @@ -721,6 +721,7 @@ runSessionWithTestConfig TestConfig{..} session = arguments { argsHlsPlugins = hlsPlugins , argsIdeOptions = ideOptions + , argsLspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } , argsDefaultHlsConfig = testLspConfig , argsProjectRoot = prjRoot , argsDisableKick = testDisableKick From 9c89410dfb7d64b1707a430ace61d1c0d4a43e1d Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 22 May 2024 13:32:29 +0800 Subject: [PATCH 48/96] add timeout --- hls-test-utils/src/Test/Hls.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index ad0dec8342..16d2922a05 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -122,7 +122,7 @@ import System.Directory (canonicalizePath, getTemporaryDirectory, makeAbsolute, setCurrentDirectory) -import System.Environment (lookupEnv, setEnv) +import System.Environment (getEnv, lookupEnv, setEnv) import System.FilePath import System.IO.Extra (newTempDirWithin) import System.IO.Unsafe (unsafePerformIO) @@ -663,7 +663,9 @@ wrapClientLogger logger = do return (lspLogRecorder <> logger, cb1) -- | Host a server, and run a test session on it. --- For detail of the test configuration, see 'TestConfig' +-- For setting custom timeout, set the environment variable 'LSP_TIMEOUT' +-- * LSP_TIMEOUT=10 cabal test +-- For more detail of the test configuration, see 'TestConfig' runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a runSessionWithTestConfig TestConfig{..} session = runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do @@ -681,7 +683,8 @@ runSessionWithTestConfig TestConfig{..} session = }] let plugins = testPluginDescriptor recorder <> lspRecorderPlugin - let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig } + timeoutOverride <- read <$> getEnv "LSP_TIMEOUT" + let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = timeoutOverride} arguments = testingArgs root recorderIde plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) From c105dc758a53d1704498e6f729c92c27c1d87364 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 26 May 2024 13:08:07 +0800 Subject: [PATCH 49/96] Update hls-test-utils/src/Test/Hls.hs Co-authored-by: fendor --- hls-test-utils/src/Test/Hls.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index ad0dec8342..1f44839762 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -618,7 +618,6 @@ data TestConfig b = TestConfig { testDirLocation :: Either FilePath VirtualFileTree -- ^ The file tree to use for the test, either a directory or a virtual file tree - -- if using a virtual file tree, -- Creates a temporary directory, and materializes the VirtualFileTree -- in the temporary directory. From f386043518c02f65b22064481d982e4feccf53a4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 13:29:13 +0800 Subject: [PATCH 50/96] add Note [Root Directory], fix comment, fix NotesTest, refactor toAbsolute --- ghcide/src/Development/IDE/Core/Shake.hs | 14 +++++++ .../src/Development/IDE/LSP/LanguageServer.hs | 5 ++- hls-plugin-api/src/Ide/PluginUtils.hs | 4 +- hls-test-utils/src/Test/Hls.hs | 3 +- .../src/Ide/Plugin/ModuleName.hs | 3 ++ plugins/hls-notes-plugin/test/NotesTest.hs | 37 ++++++++++--------- 6 files changed, 43 insertions(+), 23 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 21ac5f9e19..e31681cf63 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -527,6 +527,19 @@ newtype ShakeSession = ShakeSession -- ^ Closes the Shake session } +-- Note [Root Directory] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The root directory is the directory we assume relative paths are relative to. +-- We might be setting it from LSP workspace root > command line > from the current directory. +-- +-- Using it instead of `getCurrentDirectory` allows us to avoid issues if we +-- `setCurrentDirectory` somewhere else in the code. +-- It also helps with testing in parallel, where we can keep the root directory +-- and the current directory separate. +-- +-- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders +-- This is already deprecated and we can drop it in the future. + -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState @@ -535,6 +548,7 @@ data IdeState = IdeState ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopMonitoring :: IO () + -- see Note [Root Directory] ,rootDir :: FilePath } diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index de8eb3a6ab..58c1f49d0b 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -127,7 +127,7 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh setupLSP :: forall config err. Recorder (WithPriority Log) - -> FilePath -- ^ root directory + -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) @@ -187,7 +187,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar handleInit :: Recorder (WithPriority Log) - -> FilePath + -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () @@ -199,6 +199,7 @@ handleInit handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params -- only shift if lsp root is different from the rootDir + -- see Note [Root Directory] root <- case LSP.resRootPath env of Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot _ -> pure defaultRoot diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 9f365eeb35..3397e3918e 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -323,6 +323,4 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) -- --------------------------------------------------------------------- toAbsolute :: FilePath -> FilePath -> FilePath -toAbsolute dir file - | isAbsolute file = file - | otherwise = dir file +toAbsolute = () diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 418100c83e..49e13531d7 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -470,6 +470,7 @@ runSessionWithServer config plugin fp act = , testDirLocation = Left fp } (const act) + instance Default (TestConfig b) where def = TestConfig { testDirLocation = Right $ VirtualFileTree [] "", @@ -642,7 +643,7 @@ data TestConfig b = TestConfig , testDisableDefaultPlugin :: Bool -- ^ Whether to disable the default plugin comes with ghcide , testCheckProject :: Bool - -- ^ Whether to disable the default plugin comes with ghcide + -- ^ Whether to typecheck check the project after the session is loaded , testPluginDescriptor :: PluginTestDescriptor b -- ^ Plugin to load on the server. , testLspConfig :: Config diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 72941c2317..b185240ade 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -151,6 +151,9 @@ pathModuleNames recorder state normFilePath filePath let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) + -- TODO, this can be avoid if the filePath is already absolute, + -- we can avoid the toAbsolute call in the future. + -- see Note [Root Directory] let mdlPath = (toAbsolute $ rootDir state) filePath logWith recorder Debug (AbsoluteFilePath mdlPath) diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs index ce43a42a85..c13377aab2 100644 --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -1,7 +1,6 @@ module Main (main) where import Ide.Plugin.Notes (Log, descriptor) -import System.Directory (canonicalizePath) import System.FilePath (()) import Test.Hls @@ -14,44 +13,48 @@ main = defaultTestRunner $ [ gotoNoteTests ] +runSessionWithServer' :: FilePath -> (FilePath -> Session a) -> IO a +runSessionWithServer' fp act = + runSessionWithTestConfig def { + testLspConfig=def + , testPluginDescriptor=plugin + , testDirLocation = Left fp + } act + gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition" [ - testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do + testCase "single_file" $ runSessionWithServer' testDataDir $ \dir -> do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 3 41) - liftIO $ do - fp <- canonicalizePath $ testDataDir "NoteDef.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) - , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do + let fp = dir "NoteDef.hs" + liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) + , testCase "liberal_format" $ runSessionWithServer' testDataDir $ \dir -> do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 5 64) - liftIO $ do - fp <- canonicalizePath $ testDataDir "NoteDef.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) + let fp = dir "NoteDef.hs" + liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) - , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do + , testCase "invalid_note" $ runSessionWithServer' testDataDir $ const $ do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 6 54) - liftIO $ do - defs @?= InL (Definition (InR [])) + liftIO $ defs @?= InL (Definition (InR [])) - , testCase "no_note" $ runSessionWithServer def plugin testDataDir $ do + , testCase "no_note" $ runSessionWithServer' testDataDir $ const $ do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 1 0) liftIO $ defs @?= InL (Definition (InR [])) - , testCase "unopened_file" $ runSessionWithServer def plugin testDataDir $ do + , testCase "unopened_file" $ runSessionWithServer' testDataDir $ \dir -> do doc <- openDoc "Other.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 5 20) - liftIO $ do - fp <- canonicalizePath $ testDataDir "NoteDef.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) + let fp = dir "NoteDef.hs" + liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) ] testDataDir :: FilePath From 01f1437db499888ce0516ee589c8fefc86e4c920 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 26 May 2024 13:30:16 +0800 Subject: [PATCH 51/96] Update ghcide/src/Development/IDE/Types/HscEnvEq.hs Co-authored-by: fendor --- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index ddd5a2e214..0380f303d0 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -66,7 +66,7 @@ newHscEnvEq root cradlePath hscEnv0 deps = do -- Make Absolute since targets are also absolute importPathsCanon <- - mapM (return . toAbsolute root) $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + map (toAbsolute root) $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps From 37eacc91ff71ecfe288dac3ddfcd41e7c8c81858 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 13:37:45 +0800 Subject: [PATCH 52/96] format --- ghcide/test/exe/Config.hs | 9 ++++++--- plugins/hls-hlint-plugin/test/Main.hs | 8 ++++---- plugins/hls-refactor-plugin/test/Main.hs | 4 +++- plugins/hls-rename-plugin/test/Main.hs | 6 +++--- plugins/hls-splice-plugin/test/Main.hs | 1 + test/functional/Config.hs | 5 +++-- 6 files changed, 20 insertions(+), 13 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 8297436781..de0540eb5e 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -63,7 +63,7 @@ runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a runWithDummyPlugin' fs = runSessionWithTestConfig def { testPluginDescriptor = dummyPlugin , testDirLocation = Right fs - , testConfigCaps = lspTestCaps + , testConfigCaps = lspTestCaps , testShiftRoot = True } @@ -95,11 +95,14 @@ testSession' name = testCase name . run' run :: Session a -> IO a run = runSessionWithTestConfig def - {testDirLocation=Right (mkIdeTestFs []), testPluginDescriptor=dummyPlugin} + { testDirLocation = Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin } . const run' :: (FilePath -> Session a) -> IO a -run' = runSessionWithTestConfig def {testDirLocation=Right (mkIdeTestFs []), testPluginDescriptor=dummyPlugin} +run' = runSessionWithTestConfig def + { testDirLocation = Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin } pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index a79fe2d722..35647c8ce6 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -118,10 +118,10 @@ suggestionsTests = , testCase "falls back to pre 3.8 code actions" $ runSessionWithTestConfig def { - testConfigCaps = noLiteralCaps, - testDirLocation = Left testDir, - testPluginDescriptor = hlintPlugin, - testShiftRoot = True} $ const $ do + testConfigCaps = noLiteralCaps + , testDirLocation = Left testDir + , testPluginDescriptor = hlintPlugin + , testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 9e2a6951fc..341890e44e 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3753,7 +3753,9 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a runInDir dir act = runSessionWithTestConfig def - {testDirLocation=Left dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} + { testDirLocation=Left dir + , testPluginDescriptor=refactorPlugin + , testConfigCaps=lspTestCaps } $ const act lspTestCaps :: ClientCapabilities diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 0c031be561..57dcea28eb 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -147,7 +147,7 @@ expectRenameError doc pos newName = do runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout . runSessionWithTestConfig def - {testDirLocation= Left $ testDataDir subdir, - testPluginDescriptor=renamePlugin, - testConfigCaps=codeActionNoResolveCaps} + { testDirLocation= Left $ testDataDir subdir + , testPluginDescriptor=renamePlugin + , testConfigCaps=codeActionNoResolveCaps } . const diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 42ebd8ec8c..38cbd4d5da 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -87,6 +87,7 @@ goldenTestWithEdit fp expect tc line col = { _start = Position 0 0 , _end = Position (fromIntegral $ length lns + 1) 1 } + void waitForDiagnostics void waitForBuildQueue alt <- liftIO $ T.readFile (testDataDir fp <.> "error.hs") diff --git a/test/functional/Config.hs b/test/functional/Config.hs index a8e51531fd..9d11cff3a5 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -70,8 +70,9 @@ genericConfigTests = testGroup "generic plugin config" runConfigSession subdir session = do failIfSessionTimeout $ runSessionWithTestConfig def - {testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True - , testPluginDescriptor=plugin, testDirLocation=Left ("test/testdata" subdir)} (const session) + { testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True + , testPluginDescriptor=plugin, testDirLocation=Left ("test/testdata" subdir) } + (const session) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics From 7fff11041cba21cb8629ad729d1d948b23807830 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 13:39:15 +0800 Subject: [PATCH 53/96] format --- plugins/hls-hlint-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 35647c8ce6..8bb81021cb 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -437,7 +437,7 @@ setupGoldenHlintTest testName path = , testPluginDescriptor=hlintPlugin , testDirLocation=Left testDir } - testName testDir path "expected" "hs" + testName testDir path "expected" "hs" ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree @@ -465,4 +465,4 @@ setupGoldenHlintResolveTest testName path = , testPluginDescriptor=hlintPlugin , testDirLocation=Left testDir } - testName testDir path "expected" "hs" + testName testDir path "expected" "hs" From 5ecce5a5e5e8ccfa2417fdb4cd130b9f33bf00b0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 13:40:00 +0800 Subject: [PATCH 54/96] format --- plugins/hls-hlint-plugin/test/Main.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 8bb81021cb..99e5c7d162 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -344,8 +344,8 @@ testDir = "plugins/hls-hlint-plugin/test/testdata" runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir = failIfSessionTimeout . - runSessionWithTestConfig def - {testConfigCaps=codeActionNoResolveCaps + runSessionWithTestConfig def { + testConfigCaps=codeActionNoResolveCaps , testShiftRoot=True , testDirLocation=Left (testDir subdir) , testPluginDescriptor=hlintPlugin @@ -431,8 +431,8 @@ goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithTestConfig def - {testConfigCaps=codeActionNoResolveCaps + goldenWithTestConfig def { + testConfigCaps=codeActionNoResolveCaps , testShiftRoot=True , testPluginDescriptor=hlintPlugin , testDirLocation=Left testDir @@ -459,8 +459,8 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithTestConfig def - {testConfigCaps=codeActionResolveCaps + goldenWithTestConfig def { + testConfigCaps=codeActionResolveCaps , testShiftRoot=True , testPluginDescriptor=hlintPlugin , testDirLocation=Left testDir From f3305a5f6c9deff57027e6a9fd14d9c95c9360d3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 13:58:14 +0800 Subject: [PATCH 55/96] fix and clean up --- ghcide/src/Development/IDE/Core/Shake.hs | 1 + ghcide/src/Development/IDE/Types/HscEnvEq.hs | 3 +-- hls-test-utils/src/Test/Hls/Util.hs | 19 ------------------- 3 files changed, 2 insertions(+), 21 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index e31681cf63..cccacd2a6d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -539,6 +539,7 @@ newtype ShakeSession = ShakeSession -- -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders -- This is already deprecated and we can drop it in the future. +-- -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 0380f303d0..dc2999dee6 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -65,8 +65,7 @@ newHscEnvEq root cradlePath hscEnv0 deps = do hscEnv = removeImportPaths hscEnv0 -- Make Absolute since targets are also absolute - importPathsCanon <- - map (toAbsolute root) $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + let importPathsCanon = toAbsolute root . relativeToCradle <$> importPaths (hsc_dflags hscEnv0) newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 90ec2f07f9..92bada04f7 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -29,14 +29,12 @@ module Test.Hls.Util , dontExpectCodeAction , expectDiagnostic , expectNoMoreDiagnostics - , expectSameLocations , failIfSessionTimeout , getCompletionByLabel , noLiteralCaps , inspectCodeAction , inspectCommand , inspectDiagnostic - , SymbolLocation , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout @@ -314,23 +312,6 @@ failIfSessionTimeout action = action `catch` errorHandler errorHandler e@(Test.Timeout _) = assertFailure $ show e errorHandler e = throwIO e --- | To locate a symbol, we provide a path to the file from the HLS root --- directory, the line number, and the column number. (0 indexed.) -type SymbolLocation = (FilePath, UInt, UInt) - -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -actual `expectSameLocations` expected = do - let actual' = - Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line - , location ^. L.range . L.start . L.character)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - -- --------------------------------------------------------------------- getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem getCompletionByLabel desiredLabel compls = From 2b9a92b8e141940bf741590689e31d8ad39f3c58 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 14:01:36 +0800 Subject: [PATCH 56/96] clean import --- ghcide/test/exe/ReferenceTests.hs | 2 +- hls-plugin-api/src/Ide/PluginUtils.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index a1d6d8a0f7..864070317a 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -28,7 +28,7 @@ import Data.Tuple.Extra import GHC.TypeLits (symbolVal) import Ide.PluginUtils (toAbsolute) import Ide.Types -import System.FilePath (isAbsolute, ()) +import System.FilePath (()) import Test.Hls (FromServerMessage' (..), SMethod (..), TCustomMessage (..), diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 3397e3918e..3df96e2ca2 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -52,7 +52,7 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Server -import System.FilePath (isAbsolute, ()) +import System.FilePath (()) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as P From f831bf2a7fecc2c2f44a6ed3eb95f9eec62c2081 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 14:06:47 +0800 Subject: [PATCH 57/96] add comment --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 99eadff1f1..492f1cc1f6 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -440,7 +440,7 @@ loadSession recorder = loadSessionWithOptions recorder def loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do - let toAbsolutePath = toAbsolute rootDir + let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) From 557995208bd768b9473fa61ac0915c72a0c9fdb0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 14:11:19 +0800 Subject: [PATCH 58/96] improve Note [Root Directory] --- ghcide/src/Development/IDE/Core/Shake.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index cccacd2a6d..6a3de20faf 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -529,12 +529,13 @@ newtype ShakeSession = ShakeSession -- Note [Root Directory] -- ~~~~~~~~~~~~~~~~~~~~~ --- The root directory is the directory we assume relative paths are relative to. +-- We are keep tracking of the root directory explicitly, which is the directory where the project is located. -- We might be setting it from LSP workspace root > command line > from the current directory. -- --- Using it instead of `getCurrentDirectory` allows us to avoid issues if we --- `setCurrentDirectory` somewhere else in the code. --- It also helps with testing in parallel, where we can keep the root directory +-- It helps to remove most usage for getCurrentDirectory(After DefaultMain of GhcIde is called), +-- Using it instead of `getCurrentDirectory` allows us to avoid issues if we `setCurrentDirectory` +-- somewhere else in the code. +-- And in turn, it is helps with testing in parallel, where we can keep the root directory -- and the current directory separate. -- -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders From e4aed03db93d486e44b474efbcdebdd18c7391b6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 14:14:26 +0800 Subject: [PATCH 59/96] add TODO --- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index b88e79d2b0..82f49fed30 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -761,6 +761,7 @@ reuseParsedModule state f = do getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do + -- TODO is it safe to drop this makeAbsolute? let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t let getParsedModule f contents = do modSummary <- msrModSummary <$> From 372330781e9d89fed04f31d6e121aaf4ebcc2e2c Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 14:14:39 +0800 Subject: [PATCH 60/96] add TODO --- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 82f49fed30..34fec3a4a4 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -761,7 +761,7 @@ reuseParsedModule state f = do getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do - -- TODO is it safe to drop this makeAbsolute? + -- TODO: is it safe to drop this makeAbsolute? let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t let getParsedModule f contents = do modSummary <- msrModSummary <$> From a0d64bf415eedf7c1cd4d0f23b21d8a46e4e18d7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 14:36:52 +0800 Subject: [PATCH 61/96] fix lookupEnv --- hls-test-utils/src/Test/Hls.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 49e13531d7..cb566078b5 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -122,7 +122,7 @@ import System.Directory (canonicalizePath, getTemporaryDirectory, makeAbsolute, setCurrentDirectory) -import System.Environment (getEnv, lookupEnv, setEnv) +import System.Environment (lookupEnv, setEnv) import System.FilePath import System.IO.Extra (newTempDirWithin) import System.IO.Unsafe (unsafePerformIO) @@ -683,8 +683,8 @@ runSessionWithTestConfig TestConfig{..} session = }] let plugins = testPluginDescriptor recorder <> lspRecorderPlugin - timeoutOverride <- read <$> getEnv "LSP_TIMEOUT" - let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = timeoutOverride} + timeoutOverride <- fmap read <$> lookupEnv "LSP_TIMEOUT" + let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} arguments = testingArgs root recorderIde plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) From a1b5927149993d2d841e7f72bd5d6f4c0ecb24ca Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 16:08:32 +0800 Subject: [PATCH 62/96] typo --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6a3de20faf..6e477837c1 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -535,7 +535,7 @@ newtype ShakeSession = ShakeSession -- It helps to remove most usage for getCurrentDirectory(After DefaultMain of GhcIde is called), -- Using it instead of `getCurrentDirectory` allows us to avoid issues if we `setCurrentDirectory` -- somewhere else in the code. --- And in turn, it is helps with testing in parallel, where we can keep the root directory +-- And in turn, it helps with testing in parallel, where we can keep the root directory -- and the current directory separate. -- -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders From 7476dc48ea0f010772f9c35572d07d51b1fd8b70 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 13:25:41 +0800 Subject: [PATCH 63/96] fix Note --- ghcide/src/Development/IDE/Core/Shake.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6e477837c1..bf5c614e77 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -532,14 +532,14 @@ newtype ShakeSession = ShakeSession -- We are keep tracking of the root directory explicitly, which is the directory where the project is located. -- We might be setting it from LSP workspace root > command line > from the current directory. -- --- It helps to remove most usage for getCurrentDirectory(After DefaultMain of GhcIde is called), +-- It helps to remove most usage for `getCurrentDirectory`(After DefaultMain of GhcIde is called), -- Using it instead of `getCurrentDirectory` allows us to avoid issues if we `setCurrentDirectory` -- somewhere else in the code. -- And in turn, it helps with testing in parallel, where we can keep the root directory -- and the current directory separate. -- -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders --- This is already deprecated and we can drop it in the future. +-- This is already deprecated and we can drop it in the future when the time comes. -- -- | A Shake database plus persistent store. Can be thought of as storing From b6d5e9274a5c8e48f0b75109f2b40721d73884ae Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:17:41 +0800 Subject: [PATCH 64/96] Update ghcide/src/Development/IDE/Core/Shake.hs Co-authored-by: fendor --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index bf5c614e77..c11f32d61d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -529,7 +529,7 @@ newtype ShakeSession = ShakeSession -- Note [Root Directory] -- ~~~~~~~~~~~~~~~~~~~~~ --- We are keep tracking of the root directory explicitly, which is the directory where the project is located. +-- We keep track of the root directory explicitly, which is the directory of the project root. -- We might be setting it from LSP workspace root > command line > from the current directory. -- -- It helps to remove most usage for `getCurrentDirectory`(After DefaultMain of GhcIde is called), From 57366e74d802939eeab56d083216b6884a9fd19e Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:17:58 +0800 Subject: [PATCH 65/96] Update ghcide/src/Development/IDE/Core/Shake.hs Co-authored-by: fendor --- ghcide/src/Development/IDE/Core/Shake.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c11f32d61d..64dcf50947 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -530,7 +530,11 @@ newtype ShakeSession = ShakeSession -- Note [Root Directory] -- ~~~~~~~~~~~~~~~~~~~~~ -- We keep track of the root directory explicitly, which is the directory of the project root. --- We might be setting it from LSP workspace root > command line > from the current directory. +-- We might be setting it via these options with decreasing priority: +-- +-- 1. from LSP workspace root +-- 2. command line (--cwd) +-- 3. default to the current directory. -- -- It helps to remove most usage for `getCurrentDirectory`(After DefaultMain of GhcIde is called), -- Using it instead of `getCurrentDirectory` allows us to avoid issues if we `setCurrentDirectory` From ba50200c823ccfabd4e62525138e38c4c19b03af Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:18:35 +0800 Subject: [PATCH 66/96] Update ghcide/src/Development/IDE/Core/Shake.hs Co-authored-by: fendor --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 64dcf50947..eafdf3e3b6 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -554,7 +554,7 @@ data IdeState = IdeState ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopMonitoring :: IO () - -- see Note [Root Directory] + -- | See Note [Root Directory] ,rootDir :: FilePath } From 2f60c231b0b9caf0269965d7d6bb37da3014e2f7 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:18:58 +0800 Subject: [PATCH 67/96] Update plugins/hls-refactor-plugin/test/Main.hs Co-authored-by: fendor --- plugins/hls-refactor-plugin/test/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 341890e44e..7777eb5eec 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3753,9 +3753,9 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a runInDir dir act = runSessionWithTestConfig def - { testDirLocation=Left dir - , testPluginDescriptor=refactorPlugin - , testConfigCaps=lspTestCaps } + { testDirLocation = Left dir + , testPluginDescriptor = refactorPlugin + , testConfigCaps = lspTestCaps } $ const act lspTestCaps :: ClientCapabilities From 06dfac4700a0c8d7b073e26849ebd4042fec3fdb Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:19:08 +0800 Subject: [PATCH 68/96] Update plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs Co-authored-by: fendor --- plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 31845d8bd0..60a1349849 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -136,8 +136,8 @@ semanticTokensConfigTest = let funcVar = KV.fromList ["functionToken" .= var] var :: String var = "variable" - Test.Hls.runSessionWithTestConfig def { - testPluginDescriptor = semanticTokensPlugin + Test.Hls.runSessionWithTestConfig def + { testPluginDescriptor = semanticTokensPlugin , testConfigSession = def { ignoreConfigurationRequests = False } From afb525b1194304887823bbd7b70a321e1862b079 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:19:14 +0800 Subject: [PATCH 69/96] Update plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs Co-authored-by: fendor --- plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 60a1349849..9b84157984 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -144,7 +144,7 @@ semanticTokensConfigTest = , testConfigCaps = fullCaps , testDirLocation = Right fs , testLspConfig = mkSemanticConfig funcVar - } + } $ const $ do -- modifySemantic funcVar void waitForBuildQueue From 173b5800022207b7cfef33c747ec8ce30d6a6668 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:19:23 +0800 Subject: [PATCH 70/96] Update plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs Co-authored-by: fendor --- .../hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 9b84157984..2566a893e0 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -138,9 +138,9 @@ semanticTokensConfigTest = var = "variable" Test.Hls.runSessionWithTestConfig def { testPluginDescriptor = semanticTokensPlugin - , testConfigSession = def { - ignoreConfigurationRequests = False - } + , testConfigSession = def + { ignoreConfigurationRequests = False + } , testConfigCaps = fullCaps , testDirLocation = Right fs , testLspConfig = mkSemanticConfig funcVar From 94f94ae17be32ed35fa232ba9bbdf89afce6fe61 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:19:34 +0800 Subject: [PATCH 71/96] Update plugins/hls-rename-plugin/test/Main.hs Co-authored-by: fendor --- plugins/hls-rename-plugin/test/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 57dcea28eb..e35d7c5b06 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -147,7 +147,7 @@ expectRenameError doc pos newName = do runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout . runSessionWithTestConfig def - { testDirLocation= Left $ testDataDir subdir - , testPluginDescriptor=renamePlugin - , testConfigCaps=codeActionNoResolveCaps } + { testDirLocation = Left $ testDataDir subdir + , testPluginDescriptor = renamePlugin + , testConfigCaps = codeActionNoResolveCaps } . const From e7ec5c90b771b6e4a2960972a26a4559f099e945 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:19:53 +0800 Subject: [PATCH 72/96] Update plugins/hls-hlint-plugin/test/Main.hs Co-authored-by: fendor --- plugins/hls-hlint-plugin/test/Main.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 99e5c7d162..e7825b4dc0 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -344,12 +344,12 @@ testDir = "plugins/hls-hlint-plugin/test/testdata" runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir = failIfSessionTimeout . - runSessionWithTestConfig def { - testConfigCaps=codeActionNoResolveCaps - , testShiftRoot=True - , testDirLocation=Left (testDir subdir) - , testPluginDescriptor=hlintPlugin - } + runSessionWithTestConfig def + { testConfigCaps = codeActionNoResolveCaps + , testShiftRoot = True + , testDirLocation = Left (testDir subdir) + , testPluginDescriptor = hlintPlugin + } . const noHlintDiagnostics :: [Diagnostic] -> Assertion From a09ea8a30cb4b391a6712cd44802ec34e91e8546 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:20:36 +0800 Subject: [PATCH 73/96] Update ghcide/src/Development/IDE/Main.hs Co-authored-by: fendor --- ghcide/src/Development/IDE/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 7ac673065b..d68f4f8303 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -274,7 +274,7 @@ defaultArguments recorder fp plugins = Arguments testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments testing recorder fp plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = defaultArguments recorder fp plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins From e5297b9921dac557b81a63ae514bda6d0363d2e5 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:20:53 +0800 Subject: [PATCH 74/96] Update plugins/hls-notes-plugin/test/NotesTest.hs Co-authored-by: fendor --- plugins/hls-notes-plugin/test/NotesTest.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs index c13377aab2..f87cf98a98 100644 --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -15,9 +15,9 @@ main = defaultTestRunner $ runSessionWithServer' :: FilePath -> (FilePath -> Session a) -> IO a runSessionWithServer' fp act = - runSessionWithTestConfig def { - testLspConfig=def - , testPluginDescriptor=plugin + runSessionWithTestConfig def + { testLspConfig = def + , testPluginDescriptor = plugin , testDirLocation = Left fp } act From e7a81a3da2a18d99a1f24ede7c1c84ba4118008b Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:21:08 +0800 Subject: [PATCH 75/96] Update ghcide/test/exe/Config.hs Co-authored-by: fendor --- ghcide/test/exe/Config.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index de0540eb5e..84b3664def 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -60,8 +60,8 @@ testWithConfig :: String -> TestConfig () -> Session () -> TestTree testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a -runWithDummyPlugin' fs = runSessionWithTestConfig def { - testPluginDescriptor = dummyPlugin +runWithDummyPlugin' fs = runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin , testDirLocation = Right fs , testConfigCaps = lspTestCaps , testShiftRoot = True From c034ac4767af04a31f4882ea26fa34616c7880a2 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:21:43 +0800 Subject: [PATCH 76/96] Update plugins/hls-hlint-plugin/test/Main.hs Co-authored-by: fendor --- plugins/hls-hlint-plugin/test/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index e7825b4dc0..ba9357986e 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -117,8 +117,8 @@ suggestionsTests = liftIO $ contents @?= "main = undefined\nfoo x = x\n" , testCase "falls back to pre 3.8 code actions" $ - runSessionWithTestConfig def { - testConfigCaps = noLiteralCaps + runSessionWithTestConfig def + { testConfigCaps = noLiteralCaps , testDirLocation = Left testDir , testPluginDescriptor = hlintPlugin , testShiftRoot = True} $ const $ do From 3c7cbfabfccea140bec6cd3e0ed45d5558006095 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:21:58 +0800 Subject: [PATCH 77/96] Update ghcide/test/exe/DiagnosticTests.hs Co-authored-by: fendor --- ghcide/test/exe/DiagnosticTests.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 52dbb5068b..aab1b7f58e 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -170,11 +170,11 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs" "haskell" contentA expectDiagnostics [("ModuleB.hs", [])] , testCase "add missing module (non workspace)" $ - runSessionWithTestConfig def { - testPluginDescriptor = dummyPlugin + runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin , testConfigCaps = lspTestCapsNoFileWatches , testDirLocation = Right (mkIdeTestFs []) - } + } $ \tmpDir -> do -- By default lsp-test sends FileWatched notifications for all files, which we don't want -- as non workspace modules will not be watched by the LSP server. From eda61af8dcf5d9e6d42ed6d5f947463aae59378f Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:22:30 +0800 Subject: [PATCH 78/96] Update ghcide/test/exe/DiagnosticTests.hs Co-authored-by: fendor --- ghcide/test/exe/DiagnosticTests.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index aab1b7f58e..660dcb3241 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -581,8 +581,8 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r expectNoMoreDiagnostics 0.5 where runTestNoKick s = - runSessionWithTestConfig def { - testPluginDescriptor = dummyPlugin + runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin , testDirLocation = Right (mkIdeTestFs []) , testDisableKick = True } $ const s From b75333e0212b0378f603fe9a4b40dec9bf310ac3 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:22:52 +0800 Subject: [PATCH 79/96] Update ghcide/test/exe/ReferenceTests.hs Co-authored-by: fendor --- ghcide/test/exe/ReferenceTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 864070317a..cffbd893c8 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -172,7 +172,7 @@ getReferences' (file, l, c) includeDeclaration = do referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree referenceTestSession name thisDoc docs' f = do testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do - let rootDir = fs "" + let rootDir = addTrailingPathSeparator fs -- needed to build whole project indexing configureCheckProject True -- need to get the real paths through links From fd1632f8652a352eb0b28fa3a39f61844c0ad558 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 18:26:53 +0800 Subject: [PATCH 80/96] Update ghcide/test/exe/DependentFileTest.hs Co-authored-by: fendor --- ghcide/test/exe/DependentFileTest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index fe67647155..d2d19cf88d 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -20,8 +20,8 @@ import Test.Hls tests :: TestTree tests = testGroup "addDependentFile" [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def - {testShiftRoot=True - , testDirLocation=Right (mkIdeTestFs []) + { testShiftRoot = True + , testDirLocation = Right (mkIdeTestFs []) , testPluginDescriptor = dummyPlugin } test] ] From aecf27b057eec2eaf4c19057ccc01dfb9e8170c4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 18:34:57 +0800 Subject: [PATCH 81/96] add doc --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 492f1cc1f6..a530525756 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -913,7 +913,7 @@ newComponentCache -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components - -> FilePath -- ^ root dir + -> FilePath -- ^ root dir -- see Note [Root Directory] -> IO [ [TargetDetails] ] newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) From c91bafb565e1995d35ef4dcc08697e0ea22e2519 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 18:37:33 +0800 Subject: [PATCH 82/96] add doc --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a530525756..fec3d9caac 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -811,7 +811,7 @@ fromTargetId :: [FilePath] -- ^ import paths -> TargetId -> IdeResult HscEnvEq -> DependencyInfo - -> FilePath + -> FilePath -- ^ root dir -- see Note [Root Directory] -> IO [TargetDetails] -- For a target module we consider all the import paths fromTargetId is exts (GHC.TargetModule modName) env dep dir = do From d71cb2962b09c9be87009c630ea4745d2dfc83f1 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 18:39:31 +0800 Subject: [PATCH 83/96] format --- plugins/hls-hlint-plugin/test/Main.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index ba9357986e..0e8e3dd10e 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -459,10 +459,10 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithTestConfig def { - testConfigCaps=codeActionResolveCaps - , testShiftRoot=True - , testPluginDescriptor=hlintPlugin - , testDirLocation=Left testDir + goldenWithTestConfig def + { testConfigCaps = codeActionResolveCaps + , testShiftRoot = True + , testPluginDescriptor = hlintPlugin + , testDirLocation = Left testDir } testName testDir path "expected" "hs" From b593e691eedc19dd6dc5f3300bbdceac0464d6fa Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 18:40:16 +0800 Subject: [PATCH 84/96] format --- plugins/hls-hlint-plugin/test/Main.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 0e8e3dd10e..17f83e291a 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -431,11 +431,11 @@ goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithTestConfig def { - testConfigCaps=codeActionNoResolveCaps - , testShiftRoot=True - , testPluginDescriptor=hlintPlugin - , testDirLocation=Left testDir + goldenWithTestConfig def + { testConfigCaps = codeActionNoResolveCaps + , testShiftRoot = True + , testPluginDescriptor = hlintPlugin + , testDirLocation = Left testDir } testName testDir path "expected" "hs" From a97281ce9771c72c00b496f9376069721eb439aa Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 18:43:11 +0800 Subject: [PATCH 85/96] rename --- ghcide/src/Development/IDE/Main.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index d68f4f8303..0c1c740596 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -227,8 +227,8 @@ data Arguments = Arguments } defaultArguments :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments -defaultArguments recorder fp plugins = Arguments - { argsProjectRoot = fp +defaultArguments recorder projectRoot plugins = Arguments + { argsProjectRoot = projectRoot -- ^ see Note [Root Directory] , argCommand = LSP , argsRules = mainRule (cmapWithPrio LogRules recorder) def , argsGhcidePlugin = mempty @@ -272,10 +272,10 @@ defaultArguments recorder fp plugins = Arguments testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments -testing recorder fp plugins = +testing recorder projectRoot plugins = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = - defaultArguments recorder fp plugins + defaultArguments recorder projectRoot plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] From f75391d85863dd5eea71e1dc9b0a7bcdbe5196f0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 18:45:18 +0800 Subject: [PATCH 86/96] add doc --- ghcide/src/Development/IDE/Core/Service.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index f59d0b4afa..1ad02b4db4 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -67,7 +67,7 @@ initialise :: Recorder (WithPriority Log) -> WithHieDb -> IndexQueue -> Monitoring - -> FilePath + -> FilePath -- ^ Root directory see Note [Root Directory] -> IO IdeState initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics rootDir = do shakeProfiling <- do From f77c1541d6a7922b4cee94f010a5363b41600de4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 18:59:42 +0800 Subject: [PATCH 87/96] refine Note [Root Directory] --- ghcide/src/Development/IDE/Core/Shake.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index eafdf3e3b6..63ea81abfa 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -532,18 +532,23 @@ newtype ShakeSession = ShakeSession -- We keep track of the root directory explicitly, which is the directory of the project root. -- We might be setting it via these options with decreasing priority: -- --- 1. from LSP workspace root --- 2. command line (--cwd) +-- 1. from LSP workspace root +-- 2. command line (--cwd) -- 3. default to the current directory. -- --- It helps to remove most usage for `getCurrentDirectory`(After DefaultMain of GhcIde is called), --- Using it instead of `getCurrentDirectory` allows us to avoid issues if we `setCurrentDirectory` --- somewhere else in the code. --- And in turn, it helps with testing in parallel, where we can keep the root directory --- and the current directory separate. +-- use `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case. +-- If we modify the global Variable CWD, via `setCurrentDirectory`, all other test threads are suddenly affected, +-- forcing us to run all integration tests sequentially. +-- +-- Also, there might be a race condition if we depend on the current directory, as some plugin might change it. +-- e.g. stylish's `loadConfig`. https://github.com/haskell/haskell-language-server/issues/4234 -- -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders --- This is already deprecated and we can drop it in the future when the time comes. +-- The root dir is deprecated, but we still need this now, +-- since a lot of places in the codebase still rely on it. +-- We can drop it in the future when the condition meets: +-- 1. We can get rid all the usages of root directory in the codebase. +-- 2. LSP version we support actually removes the root directory from the protocol. -- -- | A Shake database plus persistent store. Can be thought of as storing From 6656c2eebbd2e863bc1cdce75e61648a0af3d4db Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 19:04:14 +0800 Subject: [PATCH 88/96] add doc --- ghcide/session-loader/Development/IDE/Session.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index fec3d9caac..584e298d85 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -811,7 +811,7 @@ fromTargetId :: [FilePath] -- ^ import paths -> TargetId -> IdeResult HscEnvEq -> DependencyInfo - -> FilePath -- ^ root dir -- see Note [Root Directory] + -> FilePath -- ^ root dir, see Note [Root Directory] -> IO [TargetDetails] -- For a target module we consider all the import paths fromTargetId is exts (GHC.TargetModule modName) env dep dir = do @@ -913,7 +913,7 @@ newComponentCache -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components - -> FilePath -- ^ root dir -- see Note [Root Directory] + -> FilePath -- ^ root dir, see Note [Root Directory] -> IO [ [TargetDetails] ] newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) @@ -1170,8 +1170,13 @@ addUnit unit_str = liftEwM $ do putCmdLineState (unit_str : units) -- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> FilePath -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions cfp (ComponentOptions theOpts compRoot _) dflags dir = do +setOptions :: GhcMonad m + => NormalizedFilePath + -> ComponentOptions + -> DynFlags + -> FilePath -- ^ root dir, see Note [Root Directory] + -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1194,7 +1199,7 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags dir = do -- -- If we don't end up with a target for the current file in the end, then -- we will report it as an error for that file - let abs_fp = toAbsolute dir (fromNormalizedFilePath cfp) + let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) let special_target = Compat.mkSimpleTarget df abs_fp pure $ (df, special_target : targets) :| [] where From 50d6a2fa43d4503da690db6383764c5d96b20d40 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 19:05:28 +0800 Subject: [PATCH 89/96] drop some toAbsolutePath --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 584e298d85..775e82a418 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -744,7 +744,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do void $ wait as asyncRes <- async $ getOptions file return (asyncRes, wait asyncRes) - pure $ (fmap . fmap) toAbsolutePath opts + pure opts -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From 0362913bac92bb081efb57addf2a1d8a0e46ded3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 19:13:02 +0800 Subject: [PATCH 90/96] add doc --- ghcide/src/Development/IDE/Core/Shake.hs | 4 +++- hls-plugin-api/src/Ide/PluginUtils.hs | 4 ++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 63ea81abfa..1492a3ca37 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -532,7 +532,7 @@ newtype ShakeSession = ShakeSession -- We keep track of the root directory explicitly, which is the directory of the project root. -- We might be setting it via these options with decreasing priority: -- --- 1. from LSP workspace root +-- 1. from LSP workspace root, `resRootPath` in `LanguageContextEnv`. -- 2. command line (--cwd) -- 3. default to the current directory. -- @@ -650,6 +650,8 @@ shakeOpen :: Recorder (WithPriority Log) -> Monitoring -> Rules () -> FilePath + -- ^ Root directory, this one might be picking up from `LanguageContextEnv`'s `resRootPath` + -- , see Note [Root Directory] -> IO IdeState shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 3df96e2ca2..c5609065c3 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -322,5 +322,9 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) -- --------------------------------------------------------------------- +-- | toAbsolute +-- use `toAbsolute` to state our intention that we are actually make a path absolute +-- the first argument should be the root directory +-- the second argument should be the relative path toAbsolute :: FilePath -> FilePath -> FilePath toAbsolute = () From 732d928441d6befcd71250c4a97ac5ef0de9b5c2 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 19:21:28 +0800 Subject: [PATCH 91/96] Update ghcide/src/Development/IDE/Core/Shake.hs Co-authored-by: fendor --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1492a3ca37..0ab4a1b696 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -546,7 +546,7 @@ newtype ShakeSession = ShakeSession -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders -- The root dir is deprecated, but we still need this now, -- since a lot of places in the codebase still rely on it. --- We can drop it in the future when the condition meets: +-- We can drop it in the future once: -- 1. We can get rid all the usages of root directory in the codebase. -- 2. LSP version we support actually removes the root directory from the protocol. -- From 99d66e3df513c6d9e1775f4d8fc3c3f232fb2cac Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 27 May 2024 19:21:47 +0800 Subject: [PATCH 92/96] Update ghcide/src/Development/IDE/Core/Shake.hs Co-authored-by: fendor --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0ab4a1b696..4c85bdf408 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -536,7 +536,7 @@ newtype ShakeSession = ShakeSession -- 2. command line (--cwd) -- 3. default to the current directory. -- --- use `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case. +-- Using `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case. -- If we modify the global Variable CWD, via `setCurrentDirectory`, all other test threads are suddenly affected, -- forcing us to run all integration tests sequentially. -- From 83006ad06fc6c70ea34f9d4e004940119b8411dd Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 19:35:07 +0800 Subject: [PATCH 93/96] refine doc --- ghcide/src/Development/IDE/Core/Shake.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4c85bdf408..bfd1bc1b2a 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -544,8 +544,11 @@ newtype ShakeSession = ShakeSession -- e.g. stylish's `loadConfig`. https://github.com/haskell/haskell-language-server/issues/4234 -- -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders --- The root dir is deprecated, but we still need this now, --- since a lot of places in the codebase still rely on it. +-- The root dir is deprecated, that means we should cleanup dependency on the project root(Or $CWD) thing gradually, +-- so multi-workspaces can actually be supported when we use absolute path everywhere(might also need some high level design). +-- That might not be possible unless we have everything adapt to it, like 'hlint' and 'evaluation of template haskell'. +-- But we should still be working towards the goal. +-- -- We can drop it in the future once: -- 1. We can get rid all the usages of root directory in the codebase. -- 2. LSP version we support actually removes the root directory from the protocol. From ca50997880ef1e35b8f033b9830417787da30baa Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 19:36:57 +0800 Subject: [PATCH 94/96] typo --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index bfd1bc1b2a..f759fabf63 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -546,7 +546,7 @@ newtype ShakeSession = ShakeSession -- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders -- The root dir is deprecated, that means we should cleanup dependency on the project root(Or $CWD) thing gradually, -- so multi-workspaces can actually be supported when we use absolute path everywhere(might also need some high level design). --- That might not be possible unless we have everything adapt to it, like 'hlint' and 'evaluation of template haskell'. +-- That might not be possible unless we have everything adapted to it, like 'hlint' and 'evaluation of template haskell'. -- But we should still be working towards the goal. -- -- We can drop it in the future once: From 27474b2de205a301ee0ead96f6eefc9556eda3b7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 19:41:34 +0800 Subject: [PATCH 95/96] stylish --- plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 2566a893e0..5308b6fd71 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -138,7 +138,7 @@ semanticTokensConfigTest = var = "variable" Test.Hls.runSessionWithTestConfig def { testPluginDescriptor = semanticTokensPlugin - , testConfigSession = def + , testConfigSession = def { ignoreConfigurationRequests = False } , testConfigCaps = fullCaps From 214212801f87a419ccf601e403eb14818b2752a3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 27 May 2024 20:03:03 +0800 Subject: [PATCH 96/96] fix import --- ghcide/test/exe/ReferenceTests.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index cffbd893c8..f15606ac9c 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -28,7 +28,8 @@ import Data.Tuple.Extra import GHC.TypeLits (symbolVal) import Ide.PluginUtils (toAbsolute) import Ide.Types -import System.FilePath (()) +import System.FilePath (addTrailingPathSeparator, + ()) import Test.Hls (FromServerMessage' (..), SMethod (..), TCustomMessage (..),