From e6595bb83fd37649f894a22e5a82e217d2b79fe5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 13 May 2024 11:07:00 +0800 Subject: [PATCH 01/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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/82] 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 b53c8c5b0a2204cbfe11813a719813abf0b64ec3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 13:57:47 +0800 Subject: [PATCH 48/82] refactor session --- .../session-loader/Development/IDE/Session.hs | 26 ++++++++++++++----- ghcide/src/Development/IDE/Core/RuleTypes.hs | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 99eadff1f1..f5d06ca683 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -128,6 +128,7 @@ import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State +import qualified UnliftIO as UnlifIO #endif data Log @@ -453,6 +454,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do filesMap <- newVar HM.empty :: IO (Var FilesMap) -- Version of the mappings above version <- newVar 0 + cradleLock <- newMVar () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) -- This caches the mapping from Mod.hs -> hie.yaml @@ -700,6 +702,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath]) sessionOpts (hieYaml, file) = do + -- this cased a recompilation of the whole project + -- this can be turned in to shake Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start @@ -730,8 +734,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - getOptions file = do + + let getOptions :: FilePath -> Action (IdeResult HscEnvEq, [FilePath]) + getOptions file = liftIO $ do let ncfp = toNormalizedFilePath' (toAbsolutePath file) cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file @@ -739,13 +744,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - opts <- join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - void $ wait as - asyncRes <- async $ getOptions file - return (asyncRes, wait asyncRes) + -- opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do + -- -- If the cradle is not finished, then wait for it to finish. + -- void $ wait as + -- asyncRes <- async $ getOptions file + -- return (asyncRes, wait asyncRes) + opts <- UnlifIO.withMVar cradleLock $ \_ -> getOptions file 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 -- GHC options/dynflags needed for the session and the GHC library directory @@ -1053,6 +1060,10 @@ setCacheDirs recorder CacheDirs{..} dflags = do & maybe id setHieDir hieCacheDir & maybe id setODir oCacheDir +-- tug this into shake later +-- we can make rule to build all the map +-- we can then make a rule to build each entry in the map + -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] @@ -1101,6 +1112,7 @@ data ComponentInfo = ComponentInfo } -- | Check if any dependency has been modified lately. +-- it depend on the last result checkDependencyInfo :: DependencyInfo -> IO Bool checkDependencyInfo old_di = do di <- getDependencyInfo (Map.keys old_di) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 605420d3b6..52b707fd64 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -499,7 +499,7 @@ instance NFData AddWatchedFile type instance RuleResult GhcSessionIO = IdeGhcSession data IdeGhcSession = IdeGhcSession - { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + { loadSessionFun :: FilePath -> Action (IdeResult HscEnvEq, [FilePath]) -- ^ Returns the Ghc session and the cradle dependencies , sessionVersion :: !Int -- ^ Used as Shake key, versions must be unique and not reused diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index c38a1cae3a..b022844c1f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -719,7 +719,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 + (val,deps) <- loadSessionFun $ fromNormalizedFilePath file -- add the deps to the Shake graph let addDependency fp = do From a8ecbf90a4ea348ec4ea77408128efe803a40e20 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 14:13:24 +0800 Subject: [PATCH 49/82] mask the getOptions --- ghcide/session-loader/Development/IDE/Session.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f5d06ca683..e9896c0d92 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -466,8 +466,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let res' = toAbsolutePath <$> res return $ normalise <$> res' - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) +-- dummyAs <- async $ return (error "Uninitialised") +-- runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) return $ do clientConfig <- getClientConfigAction @@ -749,7 +749,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- void $ wait as -- asyncRes <- async $ getOptions file -- return (asyncRes, wait asyncRes) - opts <- UnlifIO.withMVar cradleLock $ \_ -> getOptions file + opts <- UnlifIO.withMVarMasked cradleLock $ \_ -> getOptions file pure $ (fmap . fmap) toAbsolutePath opts From c11f0014f51f8cdeabd6fb8dc0456ba910ab36a9 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 14:15:39 +0800 Subject: [PATCH 50/82] remove the mask --- 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 e9896c0d92..619bbed31b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -749,7 +749,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- void $ wait as -- asyncRes <- async $ getOptions file -- return (asyncRes, wait asyncRes) - opts <- UnlifIO.withMVarMasked cradleLock $ \_ -> getOptions file + opts <- UnlifIO.withMVar cradleLock $ \_ -> getOptions file pure $ (fmap . fmap) toAbsolutePath opts From 021badc6d36f5705299003ff7453dc7a2da458dc Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 14:25:59 +0800 Subject: [PATCH 51/82] put wait in sync --- .../session-loader/Development/IDE/Session.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 619bbed31b..af5c23a03b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -466,8 +466,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let res' = toAbsolutePath <$> res return $ normalise <$> res' --- dummyAs <- async $ return (error "Uninitialised") --- runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) + dummyAs <- async $ return (error "Uninitialised") + runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) return $ do clientConfig <- getClientConfigAction @@ -735,8 +735,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> Action (IdeResult HscEnvEq, [FilePath]) - getOptions file = liftIO $ do + let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + getOptions file = do let ncfp = toNormalizedFilePath' (toAbsolutePath file) cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file @@ -744,12 +744,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - -- opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do - -- -- If the cradle is not finished, then wait for it to finish. - -- void $ wait as - -- asyncRes <- async $ getOptions file - -- return (asyncRes, wait asyncRes) - opts <- UnlifIO.withMVar cradleLock $ \_ -> getOptions file + opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do + -- If the cradle is not finished, then wait for it to finish. + asyncRes <- async $ wait as >> getOptions file + return (asyncRes, wait asyncRes) + -- opts <- UnlifIO.withMVar cradleLock $ \_ -> getOptions file pure $ (fmap . fmap) toAbsolutePath opts From 5a982e99dfa02d150b863fcc65626108af6d622a Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 14:59:50 +0800 Subject: [PATCH 52/82] run in async --- .../session-loader/Development/IDE/Session.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index af5c23a03b..0044a5a8e3 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -48,6 +48,7 @@ import Data.Proxy import qualified Data.Text as T import Data.Time.Clock import Data.Version +import Debug.Trace (traceM) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, knownTargets, withHieDb) @@ -455,6 +456,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- Version of the mappings above version <- newVar 0 cradleLock <- newMVar () +-- putMVar cradleLock () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) -- This caches the mapping from Mod.hs -> hie.yaml @@ -466,9 +468,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let res' = toAbsolutePath <$> res return $ normalise <$> res' - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) - return $ do clientConfig <- getClientConfigAction extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv @@ -615,6 +614,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session keys2 <- invalidateShakeCache + + -- todo this should be moving out of the session function restartShakeSession VFSUnmodified "new component" [] $ do keys1 <- extendKnownTargets all_targets return [keys1, keys2] @@ -735,8 +736,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - getOptions file = do + let getOptions :: FilePath -> Action (IdeResult HscEnvEq, [FilePath]) + getOptions file = liftIO $ do let ncfp = toNormalizedFilePath' (toAbsolutePath file) cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file @@ -744,11 +745,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - asyncRes <- async $ wait as >> getOptions file - return (asyncRes, wait asyncRes) - -- opts <- UnlifIO.withMVar cradleLock $ \_ -> getOptions file + aopts <- UnlifIO.async $ UnlifIO.withMVar cradleLock $ \_ -> do + getOptions file + opts <- UnlifIO.wait aopts pure $ (fmap . fmap) toAbsolutePath opts From 569a315b31a333291cfd221c0d0c488de46da51c Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 17:11:49 +0800 Subject: [PATCH 53/82] add CradleLoc --- .../session-loader/Development/IDE/Session.hs | 67 +++++++------------ ghcide/src/Development/IDE/Core/RuleTypes.hs | 4 ++ ghcide/src/Development/IDE/Core/Rules.hs | 11 +++ 3 files changed, 41 insertions(+), 41 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 0044a5a8e3..f6de83679d 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -123,12 +123,14 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed +import Development.IDE (Rules) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State +import Language.LSP.Protocol.Types (toNormalizedFilePath) import qualified UnliftIO as UnlifIO #endif @@ -460,13 +462,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) -- This caches the mapping from Mod.hs -> hie.yaml - cradleLoc <- liftIO $ memoIO $ \v -> do - res <- findCradle v - -- 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 - let res' = toAbsolutePath <$> res - return $ normalise <$> res' +-- cradleLoc <- liftIO $ memoIO $ \v -> do +-- res <- findCradle v +-- -- 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 +-- let res' = toAbsolutePath <$> res +-- return $ normalise <$> res' return $ do clientConfig <- getClientConfigAction @@ -701,35 +703,36 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, [FilePath]) + -> Action (IdeResult HscEnvEq, [FilePath]) sessionOpts (hieYaml, file) = do -- this cased a recompilation of the whole project -- this can be turned in to shake - Extra.whenM didSessionLoadingPreferenceConfigChange $ do + liftIO$Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + liftIO$ modifyVar_ fileToFlags (const (return Map.empty)) + liftIO$modifyVar_ filesMap (const (return HM.empty)) -- Don't even keep the name cache, we start from scratch here! - modifyVar_ hscEnvs (const (return Map.empty)) + liftIO$modifyVar_ hscEnvs (const (return Map.empty)) - v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags + -- fileToFlags is caching + v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags) let cfp = toAbsolutePath file case HM.lookup (toNormalizedFilePath' cfp) v of Just (opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di + deps_ok <- liftIO$checkDependencyInfo old_di if not deps_ok then do -- If the dependencies are out of date then clear both caches and start -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + liftIO$modifyVar_ fileToFlags (const (return Map.empty)) + liftIO$modifyVar_ filesMap (const (return HM.empty)) -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) - consultCradle hieYaml cfp + liftIO$modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) + liftIO$consultCradle hieYaml cfp else return (opts, Map.keys old_di) - Nothing -> consultCradle hieYaml cfp + Nothing -> liftIO$consultCradle hieYaml cfp -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try @@ -737,16 +740,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- before attempting to do so. let getOptions :: FilePath -> Action (IdeResult HscEnvEq, [FilePath]) - getOptions file = liftIO $ do + getOptions file = do let ncfp = toNormalizedFilePath' (toAbsolutePath file) - cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap - hieYaml <- cradleLoc file + cachedHieYamlLocation <- liftIO $ HM.lookup ncfp <$> readVar filesMap + hieYaml <- use_ CradleLoc $ toNormalizedFilePath file sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - aopts <- UnlifIO.async $ UnlifIO.withMVar cradleLock $ \_ -> do - getOptions file + aopts <- UnlifIO.async $ UnlifIO.withMVar cradleLock $ const $ getOptions file opts <- UnlifIO.wait aopts pure $ (fmap . fmap) toAbsolutePath opts @@ -1154,23 +1156,6 @@ _removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ where (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) --- | Memoize an IO function, with the characteristics: --- --- * If multiple people ask for a result simultaneously, make sure you only compute it once. --- --- * If there are exceptions, repeatedly reraise them. --- --- * If the caller is aborted (async exception) finish computing it anyway. -memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) -memoIO op = do - ref <- newVar Map.empty - return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> - case Map.lookup k mp of - Nothing -> do - res <- onceFork $ op k - return (Map.insert k res mp, res) - Just res -> return (mp, res) - unit_flags :: [Flag (CmdLineP [String])] unit_flags = [defFlag "unit" (SepArg addUnit)] diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 52b707fd64..632dd3f993 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -492,6 +492,10 @@ data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic) instance Hashable AddWatchedFile instance NFData AddWatchedFile +data CradleLoc = CradleLoc deriving (Eq, Show, Typeable, Generic) +instance Hashable CradleLoc +instance NFData CradleLoc +type instance RuleResult CradleLoc = Maybe FilePath -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index b022844c1f..f6aa83e4d7 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -178,6 +178,8 @@ import GHC (mgModSummaries) #if MIN_VERSION_ghc(9,3,0) import qualified Data.IntMap as IM +import HIE.Bios (findCradle) +import System.FilePath (normalise) #endif @@ -191,6 +193,14 @@ data Log | LogTypecheckedFOI !NormalizedFilePath deriving Show +cradleLocRule :: Recorder (WithPriority Log) -> Rules () +cradleLocRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do + res <- liftIO $ findCradle $ fromNormalizedFilePath file + -- 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 + return $ Just $ normalise <$> res + instance Pretty Log where pretty = \case LogShake msg -> pretty msg @@ -1218,6 +1228,7 @@ mainRule recorder RulesConfig{..} = do addIdeGlobal $ CompiledLinkables linkables rebuildCountVar <- liftIO $ newTVarIO 0 addIdeGlobal $ RebuildCounter rebuildCountVar + cradleLocRule recorder getParsedModuleRule recorder getParsedModuleWithCommentsRule recorder getLocatedImportsRule recorder From c417729fb9eb6e9afcc7febf8ae7feaeb833a489 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 17:51:08 +0800 Subject: [PATCH 54/82] reduce use normalized path --- .../session-loader/Development/IDE/Session.hs | 59 ++++++++++--------- ghcide/src/Development/IDE/Core/Rules.hs | 1 + 2 files changed, 31 insertions(+), 29 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f6de83679d..d87e1c2fc4 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -130,7 +130,8 @@ import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State -import Language.LSP.Protocol.Types (toNormalizedFilePath) +import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), + toNormalizedFilePath) import qualified UnliftIO as UnlifIO #endif @@ -637,13 +638,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return $ second Map.keys this_options - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - consultCradle hieYaml cfp = do - let lfpLog = makeRelative rootDir cfp + let consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) + consultCradle cfp = do + hieYaml <- use_ CradleLoc cfp + let lfpLog = makeRelative rootDir (fromNormalizedFilePath cfp) logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml rootDir + cradle <- liftIO $ loadCradle recorder hieYaml rootDir when optTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) @@ -653,8 +655,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files + old_files <- liftIO $ readIORef cradle_files + res <- liftIO $ cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files addTag "result" (show res) return res @@ -663,23 +665,22 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- The cradle gave us some options so get to work turning them -- into and HscEnv. Right (opts, libDir) -> do - installationCheck <- ghcVersionChecker libDir + installationCheck <- liftIO $ ghcVersionChecker libDir case installationCheck of InstallationNotFound{..} -> error $ "GHC installation not found in libdir: " <> libdir InstallationMismatch{..} -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) InstallationChecked _compileTime _ghcLibCheck -> do - atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) - session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + liftIO $ atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) + liftIO $ session (hieYaml, cfp, opts, libDir) -- Failure case, either a cradle error or the none cradle Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) + let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) + liftIO $ void $ modifyVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) + liftIO $ void $ modifyVar' filesMap $ HM.insert cfp hieYaml return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let @@ -702,9 +703,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: (Maybe FilePath, FilePath) + let sessionOpts :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) - sessionOpts (hieYaml, file) = do + sessionOpts file = do + hieYaml <- use_ CradleLoc file -- this cased a recompilation of the whole project -- this can be turned in to shake liftIO$Extra.whenM didSessionLoadingPreferenceConfigChange $ do @@ -718,8 +720,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- fileToFlags is caching v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags) - let cfp = toAbsolutePath file - case HM.lookup (toNormalizedFilePath' cfp) v of + case HM.lookup file v of Just (opts, old_di) -> do deps_ok <- liftIO$checkDependencyInfo old_di if not deps_ok @@ -730,24 +731,24 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do liftIO$modifyVar_ filesMap (const (return HM.empty)) -- Keep the same name cache liftIO$modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) - liftIO$consultCradle hieYaml cfp + consultCradle file else return (opts, Map.keys old_di) - Nothing -> liftIO$consultCradle hieYaml cfp + Nothing -> consultCradle file -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> Action (IdeResult HscEnvEq, [FilePath]) + let getOptions :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) getOptions file = do - let ncfp = toNormalizedFilePath' (toAbsolutePath file) - cachedHieYamlLocation <- liftIO $ HM.lookup ncfp <$> readVar filesMap - hieYaml <- use_ CradleLoc $ toNormalizedFilePath file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> + -- cachedHieYamlLocation <- liftIO $ HM.lookup ncfp <$> readVar filesMap + hieYaml <- use_ CradleLoc file + sessionOpts file `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do + let ncfp = toNormalizedFilePath' (toAbsolutePath file) aopts <- UnlifIO.async $ UnlifIO.withMVar cradleLock $ const $ getOptions file opts <- UnlifIO.wait aopts pure $ (fmap . fmap) toAbsolutePath opts @@ -1320,6 +1321,6 @@ showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwo ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." ] -renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) +renderPackageSetupException :: NormalizedFilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) fp (T.pack $ showPackageSetupException e) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index f6aa83e4d7..a44bc35402 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -199,6 +199,7 @@ cradleLocRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ -- 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 + -- todo make it absolute return $ Just $ normalise <$> res instance Pretty Log where From 6a01a456a2618b46317e7a6ff3c73ceff1b7368f Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 18:01:17 +0800 Subject: [PATCH 55/82] clean up --- ghcide/session-loader/Development/IDE/Session.hs | 15 +++------------ ghcide/src/Development/IDE/Core/RuleTypes.hs | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 3 files changed, 5 insertions(+), 14 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index d87e1c2fc4..54cfd441f9 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -462,14 +462,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- putMVar cradleLock () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) - -- This caches the mapping from Mod.hs -> hie.yaml --- cradleLoc <- liftIO $ memoIO $ \v -> do --- res <- findCradle v --- -- 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 --- let res' = toAbsolutePath <$> res --- return $ normalise <$> res' return $ do clientConfig <- getClientConfigAction @@ -647,7 +639,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do logWith recorder Warning $ LogCradleNotFound lfpLog cradle <- liftIO $ loadCradle recorder hieYaml rootDir when optTesting $ mRunLspT lspEnv $ - sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON $ fromNormalizedFilePath 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)) @@ -656,7 +648,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- liftIO $ readIORef cradle_files - res <- liftIO $ cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files + res <- liftIO $ cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle (fromNormalizedFilePath cfp) old_files addTag "result" (show res) return res @@ -672,7 +664,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do InstallationMismatch{..} -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) InstallationChecked _compileTime _ghcLibCheck -> do - liftIO $ atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) + liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) liftIO $ session (hieYaml, cfp, opts, libDir) -- Failure case, either a cradle error or the none cradle Left err -> do @@ -748,7 +740,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - let ncfp = toNormalizedFilePath' (toAbsolutePath file) aopts <- UnlifIO.async $ UnlifIO.withMVar cradleLock $ const $ getOptions file opts <- UnlifIO.wait aopts pure $ (fmap . fmap) toAbsolutePath opts diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 632dd3f993..68664facd2 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -503,7 +503,7 @@ type instance RuleResult CradleLoc = Maybe FilePath type instance RuleResult GhcSessionIO = IdeGhcSession data IdeGhcSession = IdeGhcSession - { loadSessionFun :: FilePath -> Action (IdeResult HscEnvEq, [FilePath]) + { loadSessionFun :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) -- ^ Returns the Ghc session and the cradle dependencies , sessionVersion :: !Int -- ^ Used as Shake key, versions must be unique and not reused diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index a44bc35402..b6ce8fce29 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -730,7 +730,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) <- loadSessionFun $ fromNormalizedFilePath file + (val,deps) <- loadSessionFun file -- add the deps to the Shake graph let addDependency fp = do From b6596f49b3418b0310bef1273d48d6ace2a1281a Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 18:57:12 +0800 Subject: [PATCH 56/82] move restart to async --- ghcide/session-loader/Development/IDE/Session.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 54cfd441f9..6b749acd64 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -611,9 +611,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do keys2 <- invalidateShakeCache -- todo this should be moving out of the session function - restartShakeSession VFSUnmodified "new component" [] $ do + restart <- async $ restartShakeSession VFSUnmodified "new component" [] $ do keys1 <- extendKnownTargets all_targets return [keys1, keys2] + wait restart + -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -740,8 +742,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - aopts <- UnlifIO.async $ UnlifIO.withMVar cradleLock $ const $ getOptions file - opts <- UnlifIO.wait aopts + opts <- UnlifIO.withMVar cradleLock $ const $ getOptions file pure $ (fmap . fmap) toAbsolutePath opts From 997fd9335f43f481b790062369b17297afc97a5c Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 19:02:40 +0800 Subject: [PATCH 57/82] lift UnlifIO --- ghcide/session-loader/Development/IDE/Session.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6b749acd64..d90ca3dd04 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -115,6 +115,7 @@ import HieDb.Utils import Ide.PluginUtils (toAbsolute) import qualified System.Random as Random import System.Random (RandomGen) +import qualified UnliftIO as UnlifIO -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -132,7 +133,6 @@ import GHC.Types.Error (errMsgDiagnostic, import GHC.Unit.State import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), toNormalizedFilePath) -import qualified UnliftIO as UnlifIO #endif data Log @@ -736,7 +736,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let getOptions :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) getOptions file = do - -- cachedHieYamlLocation <- liftIO $ HM.lookup ncfp <$> readVar filesMap + -- cachedHieYamlLocation <- liftIO $ HM.lookup file <$> readVar filesMap + -- CradleLoc already cached hieYaml <- use_ CradleLoc file sessionOpts file `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) From 4409fe72877726f7795d829a2399f68afce54b66 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 19:09:49 +0800 Subject: [PATCH 58/82] session using IO --- .../session-loader/Development/IDE/Session.hs | 37 ++++++++++++------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index d90ca3dd04..5c307d1332 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -115,7 +115,7 @@ import HieDb.Utils import Ide.PluginUtils (toAbsolute) import qualified System.Random as Random import System.Random (RandomGen) -import qualified UnliftIO as UnlifIO +import qualified UnliftIO as UnliftIO -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -576,19 +576,20 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) + -> Action (IdeResult HscEnvEq,[FilePath]) session args@(hieYaml, _cfp, _opts, _libDir) = do - (new_deps, old_deps) <- packageSetup args + (new_deps, old_deps) <- liftIO $ packageSetup args -- For each component, now make a new HscEnvEq which contains the -- HscEnv for the hie.yaml file but the DynFlags for that component -- For GHC's supporting multi component sessions, we create a shared -- HscEnv but set the active component accordingly - hscEnv <- emptyHscEnv ideNc _libDir + hscEnv <- liftIO $ emptyHscEnv ideNc _libDir let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv - all_target_details <- new_cache old_deps new_deps rootDir + all_target_details <- liftIO $ new_cache old_deps new_deps rootDir - this_dep_info <- getDependencyInfo $ maybeToList hieYaml + this_dep_info <- liftIO $ getDependencyInfo $ maybeToList hieYaml + -- this should be added to deps let (all_targets, this_flags_map, this_options) = case HM.lookup _cfp flags_map' of Just this -> (all_targets', flags_map', this) @@ -604,22 +605,22 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" ] - void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map - void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + liftIO $ void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map + liftIO $ void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - keys2 <- invalidateShakeCache + keys2 <- liftIO $ invalidateShakeCache -- todo this should be moving out of the session function - restart <- async $ restartShakeSession VFSUnmodified "new component" [] $ do + restart <- liftIO $ async $ restartShakeSession VFSUnmodified "new component" [] $ do keys1 <- extendKnownTargets all_targets return [keys1, keys2] - wait restart + UnliftIO.wait restart -- Typecheck all files in the project on startup - checkProject <- getCheckProject - unless (null new_deps || not checkProject) $ do + checkProject <- liftIO $ getCheckProject + liftIO $ unless (null new_deps || not checkProject) $ do cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do mmt <- uses GetModificationTime cfps' @@ -743,7 +744,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - opts <- UnlifIO.withMVar cradleLock $ const $ getOptions file + opts <- UnliftIO.withMVar cradleLock $ const $ getOptions file pure $ (fmap . fmap) toAbsolutePath opts @@ -1067,6 +1068,14 @@ type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResu -- It aims to be the reverse of 'FlagsMap'. type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) +-- file1 -> hie1.yaml -> (opts, deps) +-- file2 -> hie1.yaml -> (opts, deps) +-- file3 -> hie1.yaml -> (opts, deps) +-- if some new file4 should be in hie1.yaml, + -- we need to recompute the hie1.yaml + + + -- This is pristine information about a component data RawComponentInfo = RawComponentInfo { rawComponentUnitId :: UnitId From 40d1e3ba1146048902cb9256ab161a256d278458 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 19:11:53 +0800 Subject: [PATCH 59/82] fix --- 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 5c307d1332..4149439fca 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -668,7 +668,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) InstallationChecked _compileTime _ghcLibCheck -> do liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) - liftIO $ session (hieYaml, cfp, opts, libDir) + session (hieYaml, cfp, opts, libDir) -- Failure case, either a cradle error or the none cradle Left err -> do dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) From 29973486204939460442468864475dcb17968498 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 21:00:08 +0800 Subject: [PATCH 60/82] add rule to session loader --- .../session-loader/Development/IDE/Session.hs | 69 ++++++++++++------- ghcide/src/Development/IDE/Core/Rules.hs | 9 --- ghcide/src/Development/IDE/Main.hs | 12 ++-- 3 files changed, 50 insertions(+), 40 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4149439fca..32d6336926 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -134,9 +134,12 @@ import GHC.Unit.State import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), toNormalizedFilePath) #endif +import qualified Development.IDE.Core.Shake as SHake data Log + = LogSettingInitialDynFlags + | LogShake SHake.Log | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) | LogGetInitialGhcLibDirDefaultCradleNone | LogHieDbRetry !Int !Int !Int !SomeException @@ -157,6 +160,7 @@ data Log | LogSessionLoadingChanged deriving instance Show Log + instance Pretty Log where pretty = \case LogNoneCradleFound path -> @@ -227,6 +231,7 @@ instance Pretty Log where LogHieBios msg -> pretty msg LogSessionLoadingChanged -> "Session Loading config changed, reloading the full session." + LogShake msg -> pretty msg -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -440,10 +445,10 @@ getHieDbLoc dir = do -- This is the key function which implements multi-component support. All -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) +loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let toAbsolutePath = toAbsolute rootDir cradle_files <- newIORef [] @@ -463,7 +468,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) - return $ do + let cradleLocRule :: Rules () + cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do + res <- liftIO $ HieBios.findCradle $ fromNormalizedFilePath file + -- 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 + -- todo make it absolute + return $ Just (normalise . toAbsolutePath <$> res) + + return $ (cradleLocRule, do clientConfig <- getClientConfigAction extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras @@ -612,30 +626,30 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do keys2 <- liftIO $ invalidateShakeCache -- todo this should be moving out of the session function - restart <- liftIO $ async $ restartShakeSession VFSUnmodified "new component" [] $ do - keys1 <- extendKnownTargets all_targets - return [keys1, keys2] + restart <- liftIO $ async $ do + restartShakeSession VFSUnmodified "new component" [] $ do + keys1 <- extendKnownTargets all_targets + return [keys1, keys2] + -- Typecheck all files in the project on startup + checkProject <- liftIO $ getCheckProject + liftIO $ unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) UnliftIO.wait restart - - - -- Typecheck all files in the project on startup - checkProject <- liftIO $ getCheckProject - liftIO $ unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return $ second Map.keys this_options let consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) consultCradle cfp = do - hieYaml <- use_ CradleLoc cfp + hieYamlOld <- use_ CradleLoc cfp + cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readVar filesMap) + let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) let lfpLog = makeRelative rootDir (fromNormalizedFilePath cfp) logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $ @@ -701,7 +715,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let sessionOpts :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) sessionOpts file = do - hieYaml <- use_ CradleLoc file + hieYamlOld <- use_ CradleLoc file + cachedHieYamlLocation <- join <$> liftIO (HM.lookup file <$> readVar filesMap) + let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) -- this cased a recompilation of the whole project -- this can be turned in to shake liftIO$Extra.whenM didSessionLoadingPreferenceConfigChange $ do @@ -737,15 +753,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let getOptions :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) getOptions file = do - -- cachedHieYamlLocation <- liftIO $ HM.lookup file <$> readVar filesMap -- CradleLoc already cached hieYaml <- use_ CradleLoc file sessionOpts file `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) + returnWithVersion $ \file -> do opts <- UnliftIO.withMVar cradleLock $ const $ getOptions file - pure $ (fmap . fmap) toAbsolutePath opts + pure $ (fmap . fmap) toAbsolutePath opts) -- | Run the specific cradle on a specific FilePath via hie-bios. @@ -1074,6 +1090,9 @@ type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) -- if some new file4 should be in hie1.yaml, -- we need to recompute the hie1.yaml +-- hieRule file +-- get corresponding hie.yaml + -- This is pristine information about a component diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index b6ce8fce29..1fcda9099d 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -193,14 +193,6 @@ data Log | LogTypecheckedFOI !NormalizedFilePath deriving Show -cradleLocRule :: Recorder (WithPriority Log) -> Rules () -cradleLocRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do - res <- liftIO $ findCradle $ fromNormalizedFilePath file - -- 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 - -- todo make it absolute - return $ Just $ normalise <$> res instance Pretty Log where pretty = \case @@ -1229,7 +1221,6 @@ mainRule recorder RulesConfig{..} = do addIdeGlobal $ CompiledLinkables linkables rebuildCountVar <- liftIO $ newTVarIO 0 addIdeGlobal $ RebuildCounter rebuildCountVar - cradleLocRule recorder getParsedModuleRule recorder getParsedModuleWithCommentsRule recorder getLocatedImportsRule recorder diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 2eeb1c6067..2967c174de 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -337,7 +337,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re -- 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 rootPath + (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -356,7 +356,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins - rules + (rules <> sessionLoaderRule) (Just env) debouncer ideOptions @@ -408,14 +408,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty dir + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins (rules <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty dir shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -446,14 +446,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re let root = argsProjectRoot dbLoc <- getHieDbLoc root runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." + (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty root + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins (rules <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty root shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide From 6c4a848d4df8c6f7a8f9700988a4f4063f3017c4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 21:26:24 +0800 Subject: [PATCH 61/82] use restart to do the shakeEnqueue --- .../session-loader/Development/IDE/Session.hs | 28 ++++++++++--------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 32d6336926..fccbab6688 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -625,23 +625,25 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- Invalidate all the existing GhcSession build nodes by restarting the Shake session keys2 <- liftIO $ invalidateShakeCache + -- Typecheck all files in the project on startup + checkProject <- liftIO $ getCheckProject + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + let typeCheckAll = if null new_deps || not checkProject + then [] + else return $ + mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) -- todo this should be moving out of the session function restart <- liftIO $ async $ do - restartShakeSession VFSUnmodified "new component" [] $ do + restartShakeSession VFSUnmodified "new component" typeCheckAll $ do keys1 <- extendKnownTargets all_targets return [keys1, keys2] - -- Typecheck all files in the project on startup - checkProject <- liftIO $ getCheckProject - liftIO $ unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) UnliftIO.wait restart return $ second Map.keys this_options From eda42272e12a789fc1baa2a2720ef61b6f5089b6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 21 May 2024 22:38:40 +0800 Subject: [PATCH 62/82] cleanup --- .../session-loader/Development/IDE/Session.hs | 45 ++++++++++++------- ghcide/src/Development/IDE/Core/RuleTypes.hs | 5 +++ 2 files changed, 33 insertions(+), 17 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index fccbab6688..05529021c1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -61,7 +61,7 @@ import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util -import Development.IDE.Graph (Action) +import Development.IDE.Graph (Action, alwaysRerun) import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics @@ -134,6 +134,7 @@ import GHC.Unit.State import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), toNormalizedFilePath) #endif +import Development.IDE (RuleResult) import qualified Development.IDE.Core.Shake as SHake data Log @@ -448,6 +449,9 @@ getHieDbLoc dir = do loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def +type instance RuleResult HieYaml = (HashMap + NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) + loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let toAbsolutePath = toAbsolute rootDir @@ -461,6 +465,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. filesMap <- newVar HM.empty :: IO (Var FilesMap) + + let clearCache = do + modifyVar_ hscEnvs $ \_ -> pure Map.empty + modifyVar_ fileToFlags $ \_ -> pure Map.empty + modifyVar_ filesMap $ \_ -> pure HM.empty + -- Version of the mappings above version <- newVar 0 cradleLock <- newMVar () @@ -468,6 +478,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) + let hieYamlRule :: Rules () + hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml hieYaml -> do + alwaysRerun + v <- Map.findWithDefault HM.empty (Just $ fromNormalizedFilePath hieYaml) <$> (liftIO $ readVar fileToFlags) + return $ Just v + let cradleLocRule :: Rules () cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do res <- liftIO $ HieBios.findCradle $ fromNormalizedFilePath file @@ -477,19 +493,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- todo make it absolute return $ Just (normalise . toAbsolutePath <$> res) - return $ (cradleLocRule, do - clientConfig <- getClientConfigAction - extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv - } <- getShakeExtras - let invalidateShakeCache = do + let invalidateShakeCache = do void $ modifyVar' version succ return $ toNoFileKey GhcSessionIO + return $ (cradleLocRule <> hieYamlRule, do + clientConfig <- getClientConfigAction + ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv + } <- getShakeExtras + IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject , optExtensions } <- getIdeOptions + -- relatively stand alone -- populate the knownTargetsVar with all the -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph @@ -722,28 +740,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) -- this cased a recompilation of the whole project -- this can be turned in to shake - liftIO$Extra.whenM didSessionLoadingPreferenceConfigChange $ do + liftIO $ Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. - liftIO$ modifyVar_ fileToFlags (const (return Map.empty)) - liftIO$modifyVar_ filesMap (const (return HM.empty)) - -- Don't even keep the name cache, we start from scratch here! - liftIO$modifyVar_ hscEnvs (const (return Map.empty)) - + clearCache -- fileToFlags is caching v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags) case HM.lookup file v of Just (opts, old_di) -> do - deps_ok <- liftIO$checkDependencyInfo old_di + deps_ok <- liftIO $ checkDependencyInfo old_di if not deps_ok then do -- If the dependencies are out of date then clear both caches and start -- again. - liftIO$modifyVar_ fileToFlags (const (return Map.empty)) - liftIO$modifyVar_ filesMap (const (return HM.empty)) - -- Keep the same name cache - liftIO$modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) + liftIO $ clearCache consultCradle file else return (opts, Map.keys old_di) Nothing -> consultCradle file diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 68664facd2..8790e6ae29 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -497,6 +497,11 @@ instance Hashable CradleLoc instance NFData CradleLoc type instance RuleResult CradleLoc = Maybe FilePath +data HieYaml = HieYaml deriving (Eq, Show, Typeable, Generic) +instance Hashable HieYaml +instance NFData HieYaml + + -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 From 469700969e2ce2e19e055a41368e7c401eb4d165 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 22 May 2024 11:55:49 +0800 Subject: [PATCH 63/82] move extends out of restart --- .../session-loader/Development/IDE/Session.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 05529021c1..3a579446ad 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -481,7 +481,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let hieYamlRule :: Rules () hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml hieYaml -> do alwaysRerun + -- v :: HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) v <- Map.findWithDefault HM.empty (Just $ fromNormalizedFilePath hieYaml) <$> (liftIO $ readVar fileToFlags) + let deps = snd <$> HM.elems v + let files = concatMap Map.keys deps + -- use time for for deps files + + + -- check if all dep is up to date, if not clear the cache return $ Just v let cradleLocRule :: Rules () @@ -641,7 +648,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do liftIO $ void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - keys2 <- liftIO $ invalidateShakeCache + keys2 <- liftIO invalidateShakeCache + keys1 <- liftIO $ extendKnownTargets all_targets -- Typecheck all files in the project on startup checkProject <- liftIO $ getCheckProject @@ -660,7 +668,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- todo this should be moving out of the session function restart <- liftIO $ async $ do restartShakeSession VFSUnmodified "new component" typeCheckAll $ do - keys1 <- extendKnownTargets all_targets return [keys1, keys2] UnliftIO.wait restart return $ second Map.keys this_options @@ -745,17 +752,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- If the dependencies are out of date then clear both caches and start -- again. clearCache - -- fileToFlags is caching v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags) case HM.lookup file v of Just (opts, old_di) -> do deps_ok <- liftIO $ checkDependencyInfo old_di if not deps_ok then do - -- If the dependencies are out of date then clear both caches and start - -- again. - liftIO $ clearCache + liftIO clearCache consultCradle file + -- add the dependency info to the cache else return (opts, Map.keys old_di) Nothing -> consultCradle file From 98a8ca1f2e24fdb7582c4003fc278b327b61d984 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 22 May 2024 17:11:51 +0800 Subject: [PATCH 64/82] install cradle deps check as rule --- .../session-loader/Development/IDE/Session.hs | 447 +++++++++--------- ghcide/src/Development/IDE/Core/RuleTypes.hs | 4 + 2 files changed, 223 insertions(+), 228 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3a579446ad..0ee5557fcf 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -124,7 +124,7 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed -import Development.IDE (Rules) +import Development.IDE (Rules, getFileExists) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types @@ -449,8 +449,7 @@ getHieDbLoc dir = do loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def -type instance RuleResult HieYaml = (HashMap - NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +type instance RuleResult HieYaml = (IdeResult HscEnvEq, [FilePath]) loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do @@ -466,106 +465,117 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- you have to modify 'filesMap' as well. filesMap <- newVar HM.empty :: IO (Var FilesMap) - let clearCache = do - modifyVar_ hscEnvs $ \_ -> pure Map.empty - modifyVar_ fileToFlags $ \_ -> pure Map.empty - modifyVar_ filesMap $ \_ -> pure HM.empty - -- Version of the mappings above version <- newVar 0 + + -- version of the whole rebuild + cacheVersion <- newVar 0 cradleLock <- newMVar () -- putMVar cradleLock () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) - let hieYamlRule :: Rules () - hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml hieYaml -> do - alwaysRerun - -- v :: HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) - v <- Map.findWithDefault HM.empty (Just $ fromNormalizedFilePath hieYaml) <$> (liftIO $ readVar fileToFlags) - let deps = snd <$> HM.elems v - let files = concatMap Map.keys deps - -- use time for for deps files + let clearCache = do + modifyVar_ cacheVersion $ pure . succ + modifyVar_ hscEnvs $ \_ -> pure Map.empty + modifyVar_ fileToFlags $ \_ -> pure Map.empty + modifyVar_ filesMap $ \_ -> pure HM.empty + let + -- | We allow users to specify a loading strategy. + -- Check whether this config was changed since the last time we have loaded + -- a session. + -- + -- If the loading configuration changed, we likely should restart the session + -- in its entirety. + -- todo install it as a rule + didSessionLoadingPreferenceConfigChange :: Action Bool + didSessionLoadingPreferenceConfigChange = do + clientConfig <- getClientConfigAction + mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar + case mLoadingConfig of + Nothing -> do + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure False + Just loadingConfig -> do + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure (loadingConfig /= sessionLoading clientConfig) - -- check if all dep is up to date, if not clear the cache - return $ Just v - let cradleLocRule :: Rules () - cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do - res <- liftIO $ HieBios.findCradle $ fromNormalizedFilePath file - -- 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 - -- todo make it absolute - return $ Just (normalise . toAbsolutePath <$> res) + let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + -> Action (IdeResult HscEnvEq,[FilePath]) + session args@(hieYaml, _cfp, _opts, _libDir) = do + ShakeExtras{restartShakeSession, ideNc} <- getShakeExtras + IdeOptions{ optCheckProject = getCheckProject , optExtensions } <- getIdeOptions + (new_deps, old_deps) <- packageSetup args - let invalidateShakeCache = do - void $ modifyVar' version succ - return $ toNoFileKey GhcSessionIO + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + -- For GHC's supporting multi component sessions, we create a shared + -- HscEnv but set the active component accordingly + hscEnv <- liftIO $ emptyHscEnv ideNc _libDir + all_target_details <- liftIO $ newComponentCache recorder optExtensions hieYaml _cfp hscEnv old_deps new_deps rootDir - return $ (cradleLocRule <> hieYamlRule, do - clientConfig <- getClientConfigAction - ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv - } <- getShakeExtras + this_dep_info <- liftIO $ getDependencyInfo $ maybeToList hieYaml + -- this should be added to deps + let (all_targets, this_flags_map, this_options) + = case HM.lookup _cfp flags_map' of + Just this -> (all_targets', flags_map', this) + Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) + where all_targets' = concat all_target_details + flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] + this_flags = (this_error_env, this_dep_info) + this_error_env = ([this_error], Nothing) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp + $ T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ] - IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = getCheckProject - , optExtensions - } <- getIdeOptions + liftIO $ void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map + liftIO $ void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + -- The VFS doesn't change on cradle edits, re-use the old one. + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + keys2 <- liftIO invalidateShakeCache + keys1 <- extendKnownTargets all_targets - -- relatively stand alone - -- populate the knownTargetsVar with all the - -- files in the project so that `knownFiles` can learn about them and - -- we can generate a complete module graph - let extendKnownTargets newTargets = do - knownTargets <- concatForM newTargets $ \TargetDetails{..} -> - case targetTarget of - TargetFile f -> do - -- If a target file has multiple possible locations, then we - -- assume they are all separate file targets. - -- This happens with '.hs-boot' files if they are in the root directory of the project. - -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'. - -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the - -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'. - -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either - -- - -- * TargetFile Foo.hs-boot - -- * TargetModule Foo - -- - -- If we don't generate a TargetFile for each potential location, we will only have - -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' - -- and also not find 'TargetModule Foo'. - fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) - TargetModule _ -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - return [(targetTarget, Set.fromList found)] - hasUpdate <- atomically $ do - known <- readTVar knownTargetsVar - let known' = flip mapHashed known $ \k -> - HM.unionWith (<>) k $ HM.fromList knownTargets - hasUpdate = if known /= known' then Just (unhashed known') else Nothing - writeTVar knownTargetsVar known' - pure hasUpdate - for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated x - return $ toNoFileKey GetKnownTargets + -- Typecheck all files in the project on startup + checkProject <- liftIO getCheckProject + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + let typeCheckAll = if null new_deps || not checkProject + then [] + else return $ + mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + -- todo this should be moving out of the session function + restart <- liftIO $ async $ do + restartShakeSession VFSUnmodified "new component" typeCheckAll $ pure [keys1, keys2] + UnliftIO.wait restart + return $ second Map.keys this_options -- Create a new HscEnv from a hieYaml root and a set of options - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ([ComponentInfo], [ComponentInfo]) - packageSetup (hieYaml, cfp, opts, libDir) = do + packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) + -> Action ([ComponentInfo], [ComponentInfo]) + packageSetup (hieYaml, cfp, opts, libDir) = do + ShakeExtras{ideNc} <- getShakeExtras -- Parse DynFlags for the newly discovered component - hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + hscEnv <- liftIO $ emptyHscEnv ideNc libDir + newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps + dep_info <- liftIO $ getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do + liftIO $ modifyVar hscEnvs $ \m -> do -- Just deps if there's already an HscEnv -- Nothing is it's the first time we are making an HscEnv let oldDeps = Map.lookup hieYaml m @@ -613,82 +623,67 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let (new,old) = NE.splitAt (NE.length new_deps) all_deps' pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + -- populate the knownTargetsVar with all the + -- files in the project so that `knownFiles` can learn about them and + -- we can generate a complete module graph + extendKnownTargets newTargets = do + ShakeExtras{knownTargetsVar } <- getShakeExtras + knownTargets <- concatForM newTargets $ \TargetDetails{..} -> + case targetTarget of + TargetFile f -> do + -- If a target file has multiple possible locations, then we + -- assume they are all separate file targets. + -- This happens with '.hs-boot' files if they are in the root directory of the project. + -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'. + -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the + -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'. + -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either + -- + -- * TargetFile Foo.hs-boot + -- * TargetModule Foo + -- + -- If we don't generate a TargetFile for each potential location, we will only have + -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' + -- and also not find 'TargetModule Foo'. + fs <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) + TargetModule _ -> do + found <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + return [(targetTarget, Set.fromList found)] + hasUpdate <- liftIO $ atomically $ do + known <- readTVar knownTargetsVar + let known' = flip mapHashed known $ \k -> + HM.unionWith (<>) k $ HM.fromList knownTargets + hasUpdate = if known /= known' then Just (unhashed known') else Nothing + writeTVar knownTargetsVar known' + pure hasUpdate + for_ hasUpdate $ \x -> + logWith recorder Debug $ LogKnownFilesUpdated x + return $ toNoFileKey GetKnownTargets - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> Action (IdeResult HscEnvEq,[FilePath]) - session args@(hieYaml, _cfp, _opts, _libDir) = do - (new_deps, old_deps) <- liftIO $ packageSetup args - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - -- For GHC's supporting multi component sessions, we create a shared - -- HscEnv but set the active component accordingly - hscEnv <- liftIO $ emptyHscEnv ideNc _libDir - let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv - all_target_details <- liftIO $ new_cache old_deps new_deps rootDir - - this_dep_info <- liftIO $ getDependencyInfo $ maybeToList hieYaml - -- this should be added to deps - let (all_targets, this_flags_map, this_options) - = case HM.lookup _cfp flags_map' of - Just this -> (all_targets', flags_map', this) - Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where all_targets' = concat all_target_details - flags_map' = HM.fromList (concatMap toFlagsMap all_targets') - this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] - this_flags = (this_error_env, this_dep_info) - this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - $ T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ] - - liftIO $ void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map - liftIO $ void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) - -- The VFS doesn't change on cradle edits, re-use the old one. - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - keys2 <- liftIO invalidateShakeCache - keys1 <- liftIO $ extendKnownTargets all_targets - - -- Typecheck all files in the project on startup - checkProject <- liftIO $ getCheckProject - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - let typeCheckAll = if null new_deps || not checkProject - then [] - else return $ - mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - -- todo this should be moving out of the session function - restart <- liftIO $ async $ do - restartShakeSession VFSUnmodified "new component" typeCheckAll $ do - return [keys1, keys2] - UnliftIO.wait restart - return $ second Map.keys this_options - let consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) - consultCradle cfp = do - hieYamlOld <- use_ CradleLoc cfp - cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readVar filesMap) - let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) - let lfpLog = makeRelative rootDir (fromNormalizedFilePath cfp) - logWith recorder Info $ LogCradlePath lfpLog - when (isNothing hieYaml) $ - logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- liftIO $ loadCradle recorder hieYaml rootDir - when optTesting $ mRunLspT lspEnv $ + -- -- This caches the mapping from hie.yaml + Mod.hs -> [String] + -- -- Returns the Ghc session and the cradle dependencies + consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) + consultCradle cfp = do + clientConfig <- getClientConfigAction + ShakeExtras{lspEnv } <- getShakeExtras + IdeOptions{ optTesting = IdeTesting optTesting } <- getIdeOptions + hieYamlOld <- use_ CradleLoc cfp + cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readVar filesMap) + let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) + let lfpLog = makeRelative rootDir (fromNormalizedFilePath cfp) + logWith recorder Info $ LogCradlePath lfpLog + when (isNothing hieYaml) $ + logWith recorder Warning $ LogCradleNotFound lfpLog + cradle <- liftIO $ loadCradle recorder hieYaml rootDir + when optTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON $ fromNormalizedFilePath 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 lfpLog <> ")" - eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ + -- 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 lfpLog <> ")" + eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- liftIO $ readIORef cradle_files @@ -696,89 +691,85 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do addTag "result" (show res) return res - logWith recorder Debug $ LogSessionLoadingResult eopts - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right (opts, libDir) -> do - installationCheck <- liftIO $ ghcVersionChecker libDir - case installationCheck of - InstallationNotFound{..} -> - error $ "GHC installation not found in libdir: " <> libdir - InstallationMismatch{..} -> - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) - InstallationChecked _compileTime _ghcLibCheck -> do - liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) - session (hieYaml, cfp, opts, libDir) - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) - let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) - liftIO $ void $ modifyVar' fileToFlags $ + logWith recorder Debug $ LogSessionLoadingResult eopts + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir) -> do + installationCheck <- liftIO $ ghcVersionChecker libDir + case installationCheck of + InstallationNotFound{..} -> + error $ "GHC installation not found in libdir: " <> libdir + InstallationMismatch{..} -> + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) + InstallationChecked _compileTime _ghcLibCheck -> do + liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) + session (hieYaml, cfp, opts, libDir) + -- Failure case, either a cradle error or the none cradle + Left err -> do + dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) + let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) + liftIO $ void $ modifyVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) - liftIO $ void $ modifyVar' filesMap $ HM.insert cfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) - - let - -- | We allow users to specify a loading strategy. - -- Check whether this config was changed since the last time we have loaded - -- a session. - -- - -- If the loading configuration changed, we likely should restart the session - -- in its entirety. - didSessionLoadingPreferenceConfigChange :: IO Bool - didSessionLoadingPreferenceConfigChange = do - mLoadingConfig <- readVar biosSessionLoadingVar - case mLoadingConfig of - Nothing -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure False - Just loadingConfig -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure (loadingConfig /= sessionLoading clientConfig) - - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: NormalizedFilePath - -> Action (IdeResult HscEnvEq, [FilePath]) - sessionOpts file = do - hieYamlOld <- use_ CradleLoc file - cachedHieYamlLocation <- join <$> liftIO (HM.lookup file <$> readVar filesMap) - let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) - -- this cased a recompilation of the whole project - -- this can be turned in to shake - liftIO $ Extra.whenM didSessionLoadingPreferenceConfigChange $ do - logWith recorder Info LogSessionLoadingChanged - -- If the dependencies are out of date then clear both caches and start - -- again. - clearCache + liftIO $ void $ modifyVar' filesMap $ HM.insert cfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + + sessionCacheVersionRule :: Rules () + sessionCacheVersionRule = defineNoFile (cmapWithPrio LogShake recorder) $ \SessionCacheVersion -> do + v <- liftIO $ readVar cacheVersion + pure v + + hieYamlRule :: Rules () + hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> + -- only one cradle consult at a time + UnliftIO.withMVar cradleLock $ const $ do + hieYaml <- use_ CradleLoc file + -- check the reason we are called v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags) - case HM.lookup file v of - Just (opts, old_di) -> do - deps_ok <- liftIO $ checkDependencyInfo old_di - if not deps_ok - then do - liftIO clearCache - consultCradle file - -- add the dependency info to the cache - else return (opts, Map.keys old_di) - Nothing -> consultCradle file + catchError file hieYaml $ do + case HM.lookup file v of + -- we already have the cache but it is still called, it must be deps changed + -- clear the cache and reconsult + -- we bump the version of the cache to inform others + Just _ -> do + liftIO clearCache + -- we don't have the cache, consult + Nothing -> pure () + -- install cache version check to avoid recompilation + _ <- useNoFile_ SessionCacheVersion + result@(_, deps) <- consultCradle file + -- add the deps to the Shake graph + let addDependency fp = do + -- VSCode uses absolute paths in its filewatch notifications + let nfp = toNormalizedFilePath' fp + itExists <- getFileExists nfp + when itExists $ void $ do use_ GetModificationTime nfp + mapM_ addDependency deps + return $ Just result + where + catchError file hieYaml f = + f `Safe.catch` \e -> + return $ Just (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) + + cradleLocRule :: Rules () + cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do + res <- liftIO $ HieBios.findCradle $ fromNormalizedFilePath file + -- 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 + -- todo make it absolute + return $ Just (normalise . toAbsolutePath <$> res) + invalidateShakeCache = do + void $ modifyVar' version succ + return $ toNoFileKey GhcSessionIO + return (cradleLocRule <> hieYamlRule <> sessionCacheVersionRule, do -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - - let getOptions :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) - getOptions file = do - -- CradleLoc already cached - hieYaml <- use_ CradleLoc file - sessionOpts file `Safe.catch` \e -> - return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) - - returnWithVersion $ \file -> do - opts <- UnliftIO.withMVar cradleLock $ const $ getOptions file + opts <- use_ HieYaml file pure $ (fmap . fmap) toAbsolutePath opts) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 8790e6ae29..b56eaba2be 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -501,6 +501,10 @@ data HieYaml = HieYaml deriving (Eq, Show, Typeable, Generic) instance Hashable HieYaml instance NFData HieYaml +data SessionCacheVersion = SessionCacheVersion deriving (Eq, Show, Typeable, Generic) +instance Hashable SessionCacheVersion +instance NFData SessionCacheVersion +type instance RuleResult SessionCacheVersion = Int -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. From fa2c7c1f4a3d58f6668a31307dec17d23264d192 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 22 May 2024 17:13:52 +0800 Subject: [PATCH 65/82] fix always add SessionCacheVersion deps --- .../session-loader/Development/IDE/Session.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 0ee5557fcf..ec0d006e70 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -722,21 +722,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do hieYamlRule :: Rules () hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> -- only one cradle consult at a time - UnliftIO.withMVar cradleLock $ const $ do + UnliftIO.withMVar cradleLock $ const $ do hieYaml <- use_ CradleLoc file -- check the reason we are called v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags) + case HM.lookup file v of + -- we already have the cache but it is still called, it must be deps changed + -- clear the cache and reconsult + -- we bump the version of the cache to inform others + Just _ -> do + liftIO clearCache + -- we don't have the cache, consult + Nothing -> pure () + -- install cache version check to avoid recompilation + _ <- useNoFile_ SessionCacheVersion catchError file hieYaml $ do - case HM.lookup file v of - -- we already have the cache but it is still called, it must be deps changed - -- clear the cache and reconsult - -- we bump the version of the cache to inform others - Just _ -> do - liftIO clearCache - -- we don't have the cache, consult - Nothing -> pure () - -- install cache version check to avoid recompilation - _ <- useNoFile_ SessionCacheVersion result@(_, deps) <- consultCradle file -- add the deps to the Shake graph let addDependency fp = do From 0a4f695048b1026993ca8a0c11b7505c748373e3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 22 May 2024 17:15:56 +0800 Subject: [PATCH 66/82] fix --- ghcide/session-loader/Development/IDE/Session.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index ec0d006e70..cd5f7e19f4 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -739,17 +739,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do catchError file hieYaml $ do result@(_, deps) <- consultCradle file -- add the deps to the Shake graph - let addDependency fp = do - -- VSCode uses absolute paths in its filewatch notifications - let nfp = toNormalizedFilePath' fp - itExists <- getFileExists nfp - when itExists $ void $ do use_ GetModificationTime nfp mapM_ addDependency deps return $ Just result where catchError file hieYaml f = - f `Safe.catch` \e -> + f `Safe.catch` \e -> do + -- install dep so it can be recorvered + mapM_ addDependency hieYaml return $ Just (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) + addDependency fp = do + -- VSCode uses absolute paths in its filewatch notifications + let nfp = toNormalizedFilePath' fp + itExists <- getFileExists nfp + when itExists $ void $ do use_ GetModificationTime nfp cradleLocRule :: Rules () cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do From 83140cf9caa0440e5ac12c7983f000edfa9f67fc Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 22 May 2024 18:15:39 +0800 Subject: [PATCH 67/82] restart only on cache changed --- .../session-loader/Development/IDE/Session.hs | 70 +++++++++++-------- .../src/Development/IDE/Graph/Internal/Key.hs | 2 +- 2 files changed, 40 insertions(+), 32 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index cd5f7e19f4..194dd4a531 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -28,7 +28,7 @@ import Control.Monad import Control.Monad.Extra as Extra import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H -import Data.Aeson hiding (Error) +-- import Data.Aeson hiding (Error) import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B @@ -108,7 +108,8 @@ import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Session.Diagnostics (renderCradleError) -import Development.IDE.Types.Shake (WithHieDb, toNoFileKey) +import Development.IDE.Types.Shake (Key, WithHieDb, + toNoFileKey) import HieDb.Create import HieDb.Types import HieDb.Utils @@ -134,6 +135,7 @@ import GHC.Unit.State import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), toNormalizedFilePath) #endif +import Data.Aeson (ToJSON (toJSON)) import Development.IDE (RuleResult) import qualified Development.IDE.Core.Shake as SHake @@ -449,7 +451,7 @@ getHieDbLoc dir = do loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def -type instance RuleResult HieYaml = (IdeResult HscEnvEq, [FilePath]) +type instance RuleResult HieYaml = (IdeResult HscEnvEq, [FilePath], [NormalizedFilePath], [Key]) loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Rules (), Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do @@ -470,6 +472,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- version of the whole rebuild cacheVersion <- newVar 0 + lastRestartVersion <- newVar 0 cradleLock <- newMVar () -- putMVar cradleLock () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) @@ -502,11 +505,20 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) pure (loadingConfig /= sessionLoading clientConfig) + let typecheckAll cfps' = + mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> Action (IdeResult HscEnvEq,[FilePath]) - session args@(hieYaml, _cfp, _opts, _libDir) = do - ShakeExtras{restartShakeSession, ideNc} <- getShakeExtras +-- let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) +-- -> Action (IdeResult HscEnvEq,[FilePath]) + let session args@(hieYaml, _cfp, _opts, _libDir) = do + ShakeExtras{ideNc} <- getShakeExtras IdeOptions{ optCheckProject = getCheckProject , optExtensions } <- getIdeOptions (new_deps, old_deps) <- packageSetup args @@ -542,24 +554,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do keys1 <- extendKnownTargets all_targets -- Typecheck all files in the project on startup - checkProject <- liftIO getCheckProject cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - let typeCheckAll = if null new_deps || not checkProject - then [] - else return $ - mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - -- todo this should be moving out of the session function - restart <- liftIO $ async $ do - restartShakeSession VFSUnmodified "new component" typeCheckAll $ pure [keys1, keys2] - UnliftIO.wait restart - return $ second Map.keys this_options + let (x, y) = this_options + return $ (x, Map.keys y, cfps', [keys1, keys2]) -- Create a new HscEnv from a hieYaml root and a set of options packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) @@ -664,7 +661,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- -- Returns the Ghc session and the cradle dependencies - consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) + -- consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) consultCradle cfp = do clientConfig <- getClientConfigAction ShakeExtras{lspEnv } <- getShakeExtras @@ -701,7 +698,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do InstallationNotFound{..} -> error $ "GHC installation not found in libdir: " <> libdir InstallationMismatch{..} -> - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) InstallationChecked _compileTime _ghcLibCheck -> do liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) session (hieYaml, cfp, opts, libDir) @@ -712,7 +709,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do liftIO $ void $ modifyVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) liftIO $ void $ modifyVar' filesMap $ HM.insert cfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) sessionCacheVersionRule :: Rules () sessionCacheVersionRule = defineNoFile (cmapWithPrio LogShake recorder) $ \SessionCacheVersion -> do @@ -737,7 +734,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- install cache version check to avoid recompilation _ <- useNoFile_ SessionCacheVersion catchError file hieYaml $ do - result@(_, deps) <- consultCradle file + result@(_, deps, _, _) <- consultCradle file -- add the deps to the Shake graph mapM_ addDependency deps return $ Just result @@ -746,7 +743,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do f `Safe.catch` \e -> do -- install dep so it can be recorvered mapM_ addDependency hieYaml - return $ Just (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) + return $ Just (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml, [], []) addDependency fp = do -- VSCode uses absolute paths in its filewatch notifications let nfp = toNormalizedFilePath' fp @@ -770,9 +767,20 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. + ShakeExtras{restartShakeSession } <- getShakeExtras + IdeOptions{ optCheckProject = getCheckProject} <- getIdeOptions returnWithVersion $ \file -> do - opts <- use_ HieYaml file - pure $ (fmap . fmap) toAbsolutePath opts) + _opts@(a, b, files, keys) <- use_ HieYaml file + -- wait for the restart + lastRestartVersion' <- liftIO $ readVar lastRestartVersion + cacheVersion' <- liftIO $ readVar cacheVersion + liftIO $ when ((notNull files || notNull keys) && lastRestartVersion' /= cacheVersion') $ do + liftIO $ writeVar lastRestartVersion cacheVersion' + checkProject <- getCheckProject + -- think of not to restart a second time + async <- UnliftIO.async $ restartShakeSession VFSUnmodified "new component" (if checkProject then return (typecheckAll files) else mempty) $ pure keys + UnliftIO.wait async + pure $ (fmap . fmap) toAbsolutePath (a, b)) -- | Run the specific cradle on a specific FilePath via hie-bios. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index ba303cdb99..9bd416935e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -49,7 +49,7 @@ import Development.IDE.Graph.Classes import System.IO.Unsafe -newtype Key = UnsafeMkKey Int +newtype Key = UnsafeMkKey Int deriving (NFData) pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key pattern Key a <- (lookupKeyValue -> KeyValue a _) From 4c316464f545c6570067386dc1f42d81b1d77980 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 22 May 2024 22:50:51 +0800 Subject: [PATCH 68/82] fix --- .../session-loader/Development/IDE/Session.hs | 143 +++++++++++------- 1 file changed, 88 insertions(+), 55 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 194dd4a531..f2f7e39931 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -95,8 +95,11 @@ import System.Info import Control.Applicative (Alternative ((<|>))) import Data.Void -import Control.Concurrent.STM.Stats (atomically, modifyTVar', - readTVar, writeTVar) +import Control.Concurrent.STM.Stats (TVar, atomically, + modifyTVar', newTVar, + newTVarIO, readTVar, + readTVarIO, stateTVar, + swapTVar, writeTVar) import Control.Concurrent.STM.TQueue import Control.DeepSeq import Control.Exception (evaluate) @@ -161,11 +164,15 @@ data Log | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged + | LogCacheVersion NormalizedFilePath !Int + | LogClearingCache !NormalizedFilePath deriving instance Show Log instance Pretty Log where pretty = \case + LogClearingCache path -> + "Clearing cache for" <+> pretty (fromNormalizedFilePath path) LogNoneCradleFound path -> "None cradle found for" <+> pretty path <+> ", ignoring the file" LogSettingInitialDynFlags -> @@ -235,6 +242,8 @@ instance Pretty Log where LogSessionLoadingChanged -> "Session Loading config changed, reloading the full session." LogShake msg -> pretty msg + LogCacheVersion path version -> + "Cache version for" <+> pretty (fromNormalizedFilePath path) <+> "is" <+> pretty version -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -460,31 +469,34 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) + fileToFlags <- newTVarIO Map.empty :: IO (TVar FlagsMap) -- Mapping from a Filepath to its 'hie.yaml' location. -- Should hold the same Filepaths as 'fileToFlags', otherwise -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. - filesMap <- newVar HM.empty :: IO (Var FilesMap) + filesMap <- newTVarIO HM.empty :: IO (TVar FilesMap) -- Version of the mappings above version <- newVar 0 + + restartKeys <- newTVarIO [] + targetFiles <- newTVarIO [] -- version of the whole rebuild - cacheVersion <- newVar 0 - lastRestartVersion <- newVar 0 + cacheVersion <- newTVarIO 0 cradleLock <- newMVar () --- putMVar cradleLock () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) let clearCache = do - modifyVar_ cacheVersion $ pure . succ - modifyVar_ hscEnvs $ \_ -> pure Map.empty - modifyVar_ fileToFlags $ \_ -> pure Map.empty - modifyVar_ filesMap $ \_ -> pure HM.empty + atomically $ modifyTVar' restartKeys ([toNoFileKey SessionCacheVersion] ++) + atomically $ modifyTVar' cacheVersion succ + void $ modifyVar' hscEnvs $ \_ -> Map.empty + -- modifyTVar' hscEnvs $ \_ -> Map.empty + atomically $ modifyTVar' fileToFlags $ \_ -> Map.empty + atomically $ modifyTVar' filesMap $ \_ -> HM.empty let -- | We allow users to specify a loading strategy. -- Check whether this config was changed since the last time we have loaded @@ -546,8 +558,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" ] - liftIO $ void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map - liftIO $ void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + liftIO $ void $ atomically $ modifyTVar' fileToFlags $ Map.insert hieYaml this_flags_map + liftIO $ void $ atomically $ modifyTVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session keys2 <- liftIO invalidateShakeCache @@ -667,7 +679,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do ShakeExtras{lspEnv } <- getShakeExtras IdeOptions{ optTesting = IdeTesting optTesting } <- getIdeOptions hieYamlOld <- use_ CradleLoc cfp - cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readVar filesMap) + cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readTVarIO filesMap) let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) let lfpLog = makeRelative rootDir (fromNormalizedFilePath cfp) logWith recorder Info $ LogCradlePath lfpLog @@ -706,49 +718,66 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do Left err -> do dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) - liftIO $ void $ modifyVar' fileToFlags $ + liftIO $ atomically $ modifyTVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) - liftIO $ void $ modifyVar' filesMap $ HM.insert cfp hieYaml + liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) sessionCacheVersionRule :: Rules () sessionCacheVersionRule = defineNoFile (cmapWithPrio LogShake recorder) $ \SessionCacheVersion -> do - v <- liftIO $ readVar cacheVersion + alwaysRerun + v <- liftIO $ readTVarIO cacheVersion pure v hieYamlRule :: Rules () - hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> - -- only one cradle consult at a time - UnliftIO.withMVar cradleLock $ const $ do + hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> do hieYaml <- use_ CradleLoc file -- check the reason we are called - v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readVar fileToFlags) - case HM.lookup file v of + v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) + someThing <- case HM.lookup file v of -- we already have the cache but it is still called, it must be deps changed -- clear the cache and reconsult -- we bump the version of the cache to inform others - Just _ -> do - liftIO clearCache - -- we don't have the cache, consult - Nothing -> pure () - -- install cache version check to avoid recompilation - _ <- useNoFile_ SessionCacheVersion - catchError file hieYaml $ do - result@(_, deps, _, _) <- consultCradle file - -- add the deps to the Shake graph - mapM_ addDependency deps - return $ Just result - where - catchError file hieYaml f = - f `Safe.catch` \e -> do - -- install dep so it can be recorvered - mapM_ addDependency hieYaml - return $ Just (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml, [], []) - addDependency fp = do - -- VSCode uses absolute paths in its filewatch notifications - let nfp = toNormalizedFilePath' fp - itExists <- getFileExists nfp - when itExists $ void $ do use_ GetModificationTime nfp + Just (opts, old_di) -> do + -- need to differ two kinds of invocation, one is the file is changed + -- other is the cache version bumped + deps_ok <- liftIO $ checkDependencyInfo old_di + if not deps_ok + then do + logWith recorder Debug $ LogClearingCache file + liftIO clearCache + return Nothing + else return $ Just (opts, Map.keys old_di, [], []) + Nothing -> return Nothing + -- install cache version check to get notified when the cache is changed + -- todo but some how it is informing other, then other inform us, causing a loop + case someThing of + Just result@(_, deps, _files, _keys) -> do + mapM_ addDependency deps + return $ Just result + Nothing -> do + v <- useNoFile_ SessionCacheVersion + logWith recorder Debug $ LogCacheVersion file v + + catchError file hieYaml $ do + result@(_, deps, files, keys) <- consultCradle file + -- add the deps to the Shake graph + liftIO $ atomically $ do + modifyTVar' targetFiles (files ++ ) + modifyTVar' restartKeys (keys ++) + mapM_ addDependency deps + return $ Just result + where + catchError file hieYaml f = + f `Safe.catch` \e -> do + -- install dep so it can be recorvered + mapM_ addDependency hieYaml + return $ Just (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml, [], []) + addDependency fp = do + -- VSCode uses absolute paths in its filewatch notifications + let nfp = toNormalizedFilePath' fp + itExists <- getFileExists nfp + when itExists $ void $ do use_ GetModificationTime nfp cradleLocRule :: Rules () cradleLocRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CradleLoc file -> do @@ -769,18 +798,22 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- before attempting to do so. ShakeExtras{restartShakeSession } <- getShakeExtras IdeOptions{ optCheckProject = getCheckProject} <- getIdeOptions - returnWithVersion $ \file -> do - _opts@(a, b, files, keys) <- use_ HieYaml file - -- wait for the restart - lastRestartVersion' <- liftIO $ readVar lastRestartVersion - cacheVersion' <- liftIO $ readVar cacheVersion - liftIO $ when ((notNull files || notNull keys) && lastRestartVersion' /= cacheVersion') $ do - liftIO $ writeVar lastRestartVersion cacheVersion' - checkProject <- getCheckProject - -- think of not to restart a second time - async <- UnliftIO.async $ restartShakeSession VFSUnmodified "new component" (if checkProject then return (typecheckAll files) else mempty) $ pure keys + returnWithVersion $ \file -> + -- only one cradle consult at a time + UnliftIO.withMVar cradleLock $ const $ do + -- we need to find a way to get rid of the (files, keys) + _opts@(a, b, _files, _keys) <- use_ HieYaml file + -- _opts@(a, b, _files, _keys) <- getOptions file + async <- UnliftIO.async $ do + files <- liftIO $ atomically $ swapTVar targetFiles [] + keys <- liftIO $ atomically $ swapTVar restartKeys [] + _ <- useNoFile_ SessionCacheVersion + liftIO $ when (notNull files || notNull keys) $ do + checkProject <- getCheckProject + -- think of not to restart a second time + restartShakeSession VFSUnmodified "new component" (if checkProject then return (typecheckAll files) else mempty) $ pure keys UnliftIO.wait async - pure $ (fmap . fmap) toAbsolutePath (a, b)) + pure $ (fmap . fmap) toAbsolutePath (a, b)) -- | Run the specific cradle on a specific FilePath via hie-bios. From a03b8b3e4be01b79b75b43715e48144034f6362b Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 02:05:58 +0800 Subject: [PATCH 69/82] fix --- .../session-loader/Development/IDE/Session.hs | 244 ++++++++++-------- 1 file changed, 130 insertions(+), 114 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f2f7e39931..6ae7d77fb0 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -138,7 +138,9 @@ import GHC.Unit.State import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), toNormalizedFilePath) #endif +import Control.Concurrent.STM (STM) import Data.Aeson (ToJSON (toJSON)) +import Data.Traversable (for) import Development.IDE (RuleResult) import qualified Development.IDE.Core.Shake as SHake @@ -467,7 +469,7 @@ 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) + hscEnvs <- newTVarIO Map.empty :: IO (TVar HieMap) -- Mapping from a Filepath to HscEnv fileToFlags <- newTVarIO Map.empty :: IO (TVar FlagsMap) -- Mapping from a Filepath to its 'hie.yaml' location. @@ -477,7 +479,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do filesMap <- newTVarIO HM.empty :: IO (TVar FilesMap) -- Version of the mappings above - version <- newVar 0 + version <- newTVarIO 0 restartKeys <- newTVarIO [] @@ -487,14 +489,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do cradleLock <- newMVar () biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readTVarIO version) let clearCache = do atomically $ modifyTVar' restartKeys ([toNoFileKey SessionCacheVersion] ++) atomically $ modifyTVar' cacheVersion succ - void $ modifyVar' hscEnvs $ \_ -> Map.empty - -- modifyTVar' hscEnvs $ \_ -> Map.empty + atomically $ modifyTVar' hscEnvs $ \_ -> Map.empty atomically $ modifyTVar' fileToFlags $ \_ -> Map.empty atomically $ modifyTVar' filesMap $ \_ -> HM.empty let @@ -530,50 +531,55 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -- -> Action (IdeResult HscEnvEq,[FilePath]) let session args@(hieYaml, _cfp, _opts, _libDir) = do - ShakeExtras{ideNc} <- getShakeExtras - IdeOptions{ optCheckProject = getCheckProject , optExtensions } <- getIdeOptions - (new_deps, old_deps) <- packageSetup args - + ShakeExtras{knownTargetsVar, ideNc} <- getShakeExtras + IdeOptions{optExtensions } <- getIdeOptions + hscEnv <- liftIO $ emptyHscEnv ideNc _libDir + (new_deps, old_deps) <- packageSetup args $ const (return ()) -- For each component, now make a new HscEnvEq which contains the -- HscEnv for the hie.yaml file but the DynFlags for that component -- For GHC's supporting multi component sessions, we create a shared -- HscEnv but set the active component accordingly - hscEnv <- liftIO $ emptyHscEnv ideNc _libDir all_target_details <- liftIO $ newComponentCache recorder optExtensions hieYaml _cfp hscEnv old_deps new_deps rootDir - this_dep_info <- liftIO $ getDependencyInfo $ maybeToList hieYaml - -- this should be added to deps + -- this should be added to deps let (all_targets, this_flags_map, this_options) - = case HM.lookup _cfp flags_map' of - Just this -> (all_targets', flags_map', this) - Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where all_targets' = concat all_target_details - flags_map' = HM.fromList (concatMap toFlagsMap all_targets') - this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] - this_flags = (this_error_env, this_dep_info) - this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - $ T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ] - - liftIO $ void $ atomically $ modifyTVar' fileToFlags $ Map.insert hieYaml this_flags_map - liftIO $ void $ atomically $ modifyTVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + = case HM.lookup _cfp flags_map' of + Just this -> (all_targets', flags_map', this) + Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) + where all_targets' = concat all_target_details + flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] + this_flags = (this_error_env, this_dep_info) + this_error_env = ([this_error], Nothing) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp + $ T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ] + (keys1, knownTargets) <- extendKnownTargets all_targets + (hasUpdate, keys2) <- liftIO $ atomically $ do + modifyTVar' fileToFlags $ Map.insert hieYaml this_flags_map + modifyTVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + known <- readTVar knownTargetsVar + let known' = flip mapHashed known $ \k -> + HM.unionWith (<>) k $ HM.fromList knownTargets + hasUpdate = if known /= known' then Just (unhashed known') else Nothing + writeTVar knownTargetsVar known' + keys2 <- invalidateShakeCache + pure (hasUpdate, keys2) -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - keys2 <- liftIO invalidateShakeCache - keys1 <- extendKnownTargets all_targets - + for_ hasUpdate $ \x -> + logWith recorder Debug $ LogKnownFilesUpdated x -- Typecheck all files in the project on startup cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) let (x, y) = this_options - return $ (x, Map.keys y, cfps', [keys1, keys2]) + return (x, Map.keys y, cfps', [keys1, keys2]) -- Create a new HscEnv from a hieYaml root and a set of options packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> Action ([ComponentInfo], [ComponentInfo]) - packageSetup (hieYaml, cfp, opts, libDir) = do + -> (([ComponentInfo], [ComponentInfo]) -> STM ()) -> Action ([ComponentInfo], [ComponentInfo]) + packageSetup (hieYaml, cfp, opts, libDir) cont = do ShakeExtras{ideNc} <- getShakeExtras -- Parse DynFlags for the newly discovered component hscEnv <- liftIO $ emptyHscEnv ideNc libDir @@ -584,60 +590,60 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) - liftIO $ modifyVar hscEnvs $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs - all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps - -- Get all the unit-ids for things in this component - _inplace = map rawComponentUnitId $ NE.toList all_deps - - all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv -#if MIN_VERSION_ghc(9,3,0) - let (df2, uids) = (rawComponentDynFlags, []) -#else - let (df2, uids) = _removeInplacePackages fakeUid _inplace rawComponentDynFlags -#endif - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let hscComponents = sort $ map show uids - cacheDirOpts = hscComponents ++ componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs df2 - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo - { componentUnitId = rawComponentUnitId - , componentDynFlags = processed_df - , componentInternalUnits = uids - , componentTargets = rawComponentTargets - , componentFP = rawComponentFP - , componentCOptions = rawComponentCOptions - , componentDependencyInfo = rawComponentDependencyInfo - } - -- Modify the map so the hieYaml now maps to the newly updated - -- ComponentInfos - -- Returns - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - let (new,old) = NE.splitAt (NE.length new_deps) all_deps' - pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + -- move hscEnvs + hieDirRoot <- liftIO $ getCacheDirsRoot + liftIO $ atomically $ do + result <- stateTVar hscEnvs $ \m -> do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs + all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps + -- Get all the unit-ids for things in this component + _inplace = map rawComponentUnitId $ NE.toList all_deps + + let all_deps' = flip fmap all_deps $ \RawComponentInfo{..} -> + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv + let (df2, uids) = splitRawComponentDynFlags rawComponentCOptions + prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + hscComponents = sort $ map show uids + cacheDirOpts = hscComponents ++ componentOptions opts + cacheDirs = getCacheDirsWithRoot hieDirRoot prefix cacheDirOpts + processed_df = setCacheDirs cacheDirs df2 + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + in ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentInternalUnits = uids + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos + -- Returns + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + ((new,old), Map.insert hieYaml (NE.toList all_deps) m) + cont result + return result -- populate the knownTargetsVar with all the -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph extendKnownTargets newTargets = do - ShakeExtras{knownTargetsVar } <- getShakeExtras - knownTargets <- concatForM newTargets $ \TargetDetails{..} -> + knownTargets <- concatForM newTargets $ \TargetDetails{..} -> case targetTarget of TargetFile f -> do -- If a target file has multiple possible locations, then we @@ -659,16 +665,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do TargetModule _ -> do found <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return [(targetTarget, Set.fromList found)] - hasUpdate <- liftIO $ atomically $ do - known <- readTVar knownTargetsVar - let known' = flip mapHashed known $ \k -> - HM.unionWith (<>) k $ HM.fromList knownTargets - hasUpdate = if known /= known' then Just (unhashed known') else Nothing - writeTVar knownTargetsVar known' - pure hasUpdate - for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated x - return $ toNoFileKey GetKnownTargets + return (toNoFileKey GetKnownTargets, knownTargets) -- -- This caches the mapping from hie.yaml + Mod.hs -> [String] @@ -789,7 +786,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return $ Just (normalise . toAbsolutePath <$> res) invalidateShakeCache = do - void $ modifyVar' version succ + void $ modifyTVar' version succ return $ toNoFileKey GhcSessionIO return (cradleLocRule <> hieYamlRule <> sessionCacheVersionRule, do -- The main function which gets options for a file. We only want one of these running @@ -798,23 +795,30 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- before attempting to do so. ShakeExtras{restartShakeSession } <- getShakeExtras IdeOptions{ optCheckProject = getCheckProject} <- getIdeOptions - returnWithVersion $ \file -> + returnWithVersion $ \file -> do + -- do -- only one cradle consult at a time - UnliftIO.withMVar cradleLock $ const $ do - -- we need to find a way to get rid of the (files, keys) - _opts@(a, b, _files, _keys) <- use_ HieYaml file - -- _opts@(a, b, _files, _keys) <- getOptions file - async <- UnliftIO.async $ do - files <- liftIO $ atomically $ swapTVar targetFiles [] - keys <- liftIO $ atomically $ swapTVar restartKeys [] - _ <- useNoFile_ SessionCacheVersion - liftIO $ when (notNull files || notNull keys) $ do - checkProject <- getCheckProject - -- think of not to restart a second time - restartShakeSession VFSUnmodified "new component" (if checkProject then return (typecheckAll files) else mempty) $ pure keys - UnliftIO.wait async - pure $ (fmap . fmap) toAbsolutePath (a, b)) - + async <- + UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do + -- we need to find a way to get rid of the (files, keys) + _opts@(a, b, _files, _keys) <- use_ HieYaml file + -- _opts@(a, b, _files, _keys) <- getOptions file + files <- liftIO $ atomically $ swapTVar targetFiles [] + keys <- liftIO $ atomically $ swapTVar restartKeys [] + _ <- useNoFile_ SessionCacheVersion + liftIO $ when (notNull files || notNull keys) $ do + checkProject <- getCheckProject + -- think of not to restart a second time + restartShakeSession VFSUnmodified "new component" (if checkProject then return (typecheckAll files) else mempty) $ pure keys + pure $ (a, fmap toAbsolutePath b) + UnliftIO.wait async) + +splitRawComponentDynFlags rawComponentDynFlags = +#if MIN_VERSION_ghc(9,3,0) + (rawComponentDynFlags, []) +#else + _removeInplacePackages fakeUid _inplace rawComponentDynFlags +#endif -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -1115,10 +1119,9 @@ should be filtered out, such that we dont have to re-compile everything. -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs recorder CacheDirs{..} dflags = do - logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) - pure $ dflags +setCacheDirs :: CacheDirs -> DynFlags -> DynFlags +setCacheDirs CacheDirs{..} dflags = do + dflags & maybe id setHiDir hiCacheDir & maybe id setHieDir hieCacheDir & maybe id setODir oCacheDir @@ -1344,6 +1347,19 @@ getCacheDirsDefault prefix opts = do -- GHC options will create incompatible interface files. opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) +getCacheDirsRoot :: IO String +getCacheDirsRoot = getXdgDirectory XdgCache cacheDir + +getCacheDirsWithRoot :: String -> String -> [String] -> CacheDirs +getCacheDirsWithRoot root prefix opts = do + let dir = Just (root prefix ++ "-" ++ opts_hash) + CacheDirs dir dir dir + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + + -- | Sub directory for the cache path cacheDir :: String cacheDir = "ghcide" From 5d50087e86dace534ba156728753c4901adbd56e Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 02:16:26 +0800 Subject: [PATCH 70/82] para more --- ghcide/session-loader/Development/IDE/Session.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6ae7d77fb0..de1c4bf993 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -607,9 +607,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do _inplace = map rawComponentUnitId $ NE.toList all_deps let all_deps' = flip fmap all_deps $ \RawComponentInfo{..} -> - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv - let (df2, uids) = splitRawComponentDynFlags rawComponentCOptions + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv + let (df2, uids) = splitRawComponentDynFlags rawComponentDynFlags prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] hscComponents = sort $ map show uids @@ -710,7 +710,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) InstallationChecked _compileTime _ghcLibCheck -> do liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) - session (hieYaml, cfp, opts, libDir) + async <- UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ session (hieYaml, cfp, opts, libDir) + UnliftIO.wait async -- Failure case, either a cradle error or the none cradle Left err -> do dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) @@ -798,10 +799,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do returnWithVersion $ \file -> do -- do -- only one cradle consult at a time + + -- we need to find a way to get rid of the (files, keys) + _opts@(a, b, _files, _keys) <- use_ HieYaml file async <- - UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do - -- we need to find a way to get rid of the (files, keys) - _opts@(a, b, _files, _keys) <- use_ HieYaml file + UnliftIO.async $ do -- _opts@(a, b, _files, _keys) <- getOptions file files <- liftIO $ atomically $ swapTVar targetFiles [] keys <- liftIO $ atomically $ swapTVar restartKeys [] From 7c9e5d2662dcd3f3bf01fdc82f3fe72e4e518f8b Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 02:20:44 +0800 Subject: [PATCH 71/82] fix and revert para --- ghcide/session-loader/Development/IDE/Session.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index de1c4bf993..0ba23a694f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -607,8 +607,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do _inplace = map rawComponentUnitId $ NE.toList all_deps let all_deps' = flip fmap all_deps $ \RawComponentInfo{..} -> - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv let (df2, uids) = splitRawComponentDynFlags rawComponentDynFlags prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] @@ -710,8 +710,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) InstallationChecked _compileTime _ghcLibCheck -> do liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) - async <- UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ session (hieYaml, cfp, opts, libDir) - UnliftIO.wait async + session (hieYaml, cfp, opts, libDir) -- Failure case, either a cradle error or the none cradle Left err -> do dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) @@ -799,11 +798,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do returnWithVersion $ \file -> do -- do -- only one cradle consult at a time - - -- we need to find a way to get rid of the (files, keys) - _opts@(a, b, _files, _keys) <- use_ HieYaml file async <- - UnliftIO.async $ do + UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do + -- we need to find a way to get rid of the (files, keys) + _opts@(a, b, _files, _keys) <- use_ HieYaml file -- _opts@(a, b, _files, _keys) <- getOptions file files <- liftIO $ atomically $ swapTVar targetFiles [] keys <- liftIO $ atomically $ swapTVar restartKeys [] From 4f416cdca0261d1a5675fde4ed9a092382a0403f Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 12:43:57 +0800 Subject: [PATCH 72/82] fix --- ghcide/session-loader/Development/IDE/Session.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 0ba23a694f..7a03dac6ea 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -95,6 +95,7 @@ import System.Info import Control.Applicative (Alternative ((<|>))) import Data.Void +import Control.Concurrent.STM (STM) import Control.Concurrent.STM.Stats (TVar, atomically, modifyTVar', newTVar, newTVarIO, readTVar, @@ -104,11 +105,16 @@ import Control.Concurrent.STM.TQueue import Control.DeepSeq import Control.Exception (evaluate) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Aeson (ToJSON (toJSON)) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set +import Data.Traversable (for) import Database.SQLite.Simple +import Development.IDE (RuleResult, Rules, + getFileExists) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (Key, WithHieDb, @@ -128,7 +134,6 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed -import Development.IDE (Rules, getFileExists) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types @@ -138,16 +143,11 @@ import GHC.Unit.State import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), toNormalizedFilePath) #endif -import Control.Concurrent.STM (STM) -import Data.Aeson (ToJSON (toJSON)) -import Data.Traversable (for) -import Development.IDE (RuleResult) -import qualified Development.IDE.Core.Shake as SHake data Log = LogSettingInitialDynFlags - | LogShake SHake.Log + | LogShake Shake.Log | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) | LogGetInitialGhcLibDirDefaultCradleNone | LogHieDbRetry !Int !Int !Int !SomeException From 17922a50d3482bce5356460d3f9b9a925d8549c9 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 18:01:59 +0800 Subject: [PATCH 73/82] move parallel more --- .../session-loader/Development/IDE/Session.hs | 130 ++++++++---------- 1 file changed, 61 insertions(+), 69 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7a03dac6ea..8dd17da904 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -140,8 +140,6 @@ import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State -import Language.LSP.Protocol.Types (NormalizedUri (NormalizedUri), - toNormalizedFilePath) #endif data Log @@ -609,7 +607,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do let all_deps' = flip fmap all_deps $ \RawComponentInfo{..} -> -- Remove all inplace dependencies from package flags for -- components in this HscEnv - let (df2, uids) = splitRawComponentDynFlags rawComponentDynFlags + let (df2, uids) = +#if MIN_VERSION_ghc(9,3,0) + (rawComponentDynFlags, []) +#else + _removeInplacePackages fakeUid _inplace rawComponentDynFlags +#endif prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] hscComponents = sort $ map show uids @@ -671,10 +674,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- -- Returns the Ghc session and the cradle dependencies -- consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) - consultCradle cfp = do + consultCradle cfp clearFlag = do clientConfig <- getClientConfigAction - ShakeExtras{lspEnv } <- getShakeExtras - IdeOptions{ optTesting = IdeTesting optTesting } <- getIdeOptions + ShakeExtras{lspEnv, restartShakeSession } <- getShakeExtras + IdeOptions{ optTesting = IdeTesting optTesting, optCheckProject = getCheckProject } <- getIdeOptions hieYamlOld <- use_ CradleLoc cfp cachedHieYamlLocation <- join <$> liftIO (HM.lookup cfp <$> readTVarIO filesMap) let hieYaml = fromMaybe cachedHieYamlLocation (Just hieYamlOld) @@ -698,27 +701,40 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do return res logWith recorder Debug $ LogSessionLoadingResult eopts - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right (opts, libDir) -> do - installationCheck <- liftIO $ ghcVersionChecker libDir - case installationCheck of - InstallationNotFound{..} -> - error $ "GHC installation not found in libdir: " <> libdir - InstallationMismatch{..} -> - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) - InstallationChecked _compileTime _ghcLibCheck -> do - liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) - session (hieYaml, cfp, opts, libDir) - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) - let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) - liftIO $ atomically $ modifyTVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) - liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) + + result <- UnliftIO.withMVar cradleLock $ const $ UnliftIO.async $ do + when clearFlag $ do + liftIO $ clearCache + logWith recorder Info LogSessionLoadingChanged + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir) -> do + installationCheck <- liftIO $ ghcVersionChecker libDir + case installationCheck of + InstallationNotFound{..} -> + error $ "GHC installation not found in libdir: " <> libdir + InstallationMismatch{..} -> + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) + InstallationChecked _compileTime _ghcLibCheck -> do + liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) + result@(_, _, files, keys) <- session (hieYaml, cfp, opts, libDir) + liftIO $ when (notNull files || notNull keys) $ do + checkProject <- getCheckProject + -- think of not to restart a second time + restartShakeSession VFSUnmodified "new component" + (if checkProject then return (typecheckAll files) else mempty) + (pure keys) + return result + -- Failure case, either a cradle error or the none cradle + Left err -> do + dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) + let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) + liftIO $ atomically $ modifyTVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) + liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) + UnliftIO.wait result sessionCacheVersionRule :: Rules () sessionCacheVersionRule = defineNoFile (cmapWithPrio LogShake recorder) $ \SessionCacheVersion -> do @@ -727,11 +743,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do pure v hieYamlRule :: Rules () - hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> do + hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> Just <$> hieYamlRuleImpl file + + hieYamlRuleImpl file = do hieYaml <- use_ CradleLoc file -- check the reason we are called v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) - someThing <- case HM.lookup file v of + catchError file hieYaml $ + case HM.lookup file v of -- we already have the cache but it is still called, it must be deps changed -- clear the cache and reconsult -- we bump the version of the cache to inform others @@ -742,34 +761,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do if not deps_ok then do logWith recorder Debug $ LogClearingCache file - liftIO clearCache - return Nothing - else return $ Just (opts, Map.keys old_di, [], []) - Nothing -> return Nothing - -- install cache version check to get notified when the cache is changed - -- todo but some how it is informing other, then other inform us, causing a loop - case someThing of - Just result@(_, deps, _files, _keys) -> do - mapM_ addDependency deps - return $ Just result - Nothing -> do - v <- useNoFile_ SessionCacheVersion - logWith recorder Debug $ LogCacheVersion file v - - catchError file hieYaml $ do - result@(_, deps, files, keys) <- consultCradle file - -- add the deps to the Shake graph - liftIO $ atomically $ do - modifyTVar' targetFiles (files ++ ) - modifyTVar' restartKeys (keys ++) - mapM_ addDependency deps - return $ Just result + -- liftIO clearCache + consultCradle file True + else return (opts, Map.keys old_di, [], []) + Nothing -> consultCradle file False where catchError file hieYaml f = f `Safe.catch` \e -> do -- install dep so it can be recorvered mapM_ addDependency hieYaml - return $ Just (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml, [], []) + return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml, [], []) addDependency fp = do -- VSCode uses absolute paths in its filewatch notifications let nfp = toNormalizedFilePath' fp @@ -798,22 +799,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do returnWithVersion $ \file -> do -- do -- only one cradle consult at a time - async <- - UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do - -- we need to find a way to get rid of the (files, keys) - _opts@(a, b, _files, _keys) <- use_ HieYaml file - -- _opts@(a, b, _files, _keys) <- getOptions file - files <- liftIO $ atomically $ swapTVar targetFiles [] - keys <- liftIO $ atomically $ swapTVar restartKeys [] - _ <- useNoFile_ SessionCacheVersion - liftIO $ when (notNull files || notNull keys) $ do - checkProject <- getCheckProject - -- think of not to restart a second time - restartShakeSession VFSUnmodified "new component" (if checkProject then return (typecheckAll files) else mempty) $ pure keys - pure $ (a, fmap toAbsolutePath b) - UnliftIO.wait async) - -splitRawComponentDynFlags rawComponentDynFlags = + -- we need to find a way to get rid of the (files, keys) + _opts@(a, b, _files, _keys) <- hieYamlRuleImpl file + -- _opts@(a, b, _files, _keys) <- getOptions file + pure (a, fmap toAbsolutePath b) + ) + +splitRawComponentDynFlags rawComponentDynFlags _inplace = #if MIN_VERSION_ghc(9,3,0) (rawComponentDynFlags, []) #else @@ -1005,7 +997,7 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do #if MIN_VERSION_ghc(9,3,0) let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs + multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) "" . T.pack . Compat.printWithoutUniques) closure_errs bad_units = OS.fromList $ concat $ do x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs DriverHomePackagesNotClosed us <- pure x From 2061a710ae30c3ffd4ee12c16557879dd6493a66 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 18:12:50 +0800 Subject: [PATCH 74/82] clear early --- ghcide/session-loader/Development/IDE/Session.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8dd17da904..d61d2acd15 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -703,9 +703,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do logWith recorder Debug $ LogSessionLoadingResult eopts result <- UnliftIO.withMVar cradleLock $ const $ UnliftIO.async $ do - when clearFlag $ do - liftIO $ clearCache - logWith recorder Info LogSessionLoadingChanged case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -761,7 +758,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do if not deps_ok then do logWith recorder Debug $ LogClearingCache file - -- liftIO clearCache + liftIO clearCache consultCradle file True else return (opts, Map.keys old_di, [], []) Nothing -> consultCradle file False From 03b5add88723cc8c87a0ac39e5c1ed3e8d86a3f4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 21:47:42 +0800 Subject: [PATCH 75/82] double check --- .../session-loader/Development/IDE/Session.hs | 88 +++++++++++-------- 1 file changed, 53 insertions(+), 35 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index d61d2acd15..1823ff61b9 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -674,7 +674,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- -- Returns the Ghc session and the cradle dependencies -- consultCradle :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath]) - consultCradle cfp clearFlag = do + consultCradle cfp = do clientConfig <- getClientConfigAction ShakeExtras{lspEnv, restartShakeSession } <- getShakeExtras IdeOptions{ optTesting = IdeTesting optTesting, optCheckProject = getCheckProject } <- getIdeOptions @@ -703,34 +703,36 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do logWith recorder Debug $ LogSessionLoadingResult eopts result <- UnliftIO.withMVar cradleLock $ const $ UnliftIO.async $ do - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right (opts, libDir) -> do - installationCheck <- liftIO $ ghcVersionChecker libDir - case installationCheck of - InstallationNotFound{..} -> - error $ "GHC installation not found in libdir: " <> libdir - InstallationMismatch{..} -> - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) - InstallationChecked _compileTime _ghcLibCheck -> do - liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) - result@(_, _, files, keys) <- session (hieYaml, cfp, opts, libDir) - liftIO $ when (notNull files || notNull keys) $ do - checkProject <- getCheckProject - -- think of not to restart a second time - restartShakeSession VFSUnmodified "new component" - (if checkProject then return (typecheckAll files) else mempty) - (pure keys) - return result - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) - let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) - liftIO $ atomically $ modifyTVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) - liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) + -- clear cache if the cradle is changed + checkCache cfp $ + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir) -> do + installationCheck <- liftIO $ ghcVersionChecker libDir + case installationCheck of + InstallationNotFound{..} -> + error $ "GHC installation not found in libdir: " <> libdir + InstallationMismatch{..} -> + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) + InstallationChecked _compileTime _ghcLibCheck -> do + liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) + result@(_, _, files, keys) <- session (hieYaml, cfp, opts, libDir) + liftIO $ when (notNull files || notNull keys) $ do + checkProject <- getCheckProject + -- think of not to restart a second time + restartShakeSession VFSUnmodified "new component" + (if checkProject then return (typecheckAll files) else mempty) + (pure keys) + return result + -- Failure case, either a cradle error or the none cradle + Left err -> do + dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) + let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) + liftIO $ atomically $ modifyTVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) + liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) UnliftIO.wait result sessionCacheVersionRule :: Rules () @@ -742,12 +744,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do hieYamlRule :: Rules () hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> Just <$> hieYamlRuleImpl file - hieYamlRuleImpl file = do + checkCache file run = do hieYaml <- use_ CradleLoc file -- check the reason we are called v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) - catchError file hieYaml $ - case HM.lookup file v of + case HM.lookup file v of -- we already have the cache but it is still called, it must be deps changed -- clear the cache and reconsult -- we bump the version of the cache to inform others @@ -759,9 +760,27 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do then do logWith recorder Debug $ LogClearingCache file liftIO clearCache - consultCradle file True + run + else return (opts, Map.keys old_di, [], []) + Nothing -> run + + hieYamlRuleImpl file = do + hieYaml <- use_ CradleLoc file + -- check the reason we are called + v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) + catchError file hieYaml $ + case HM.lookup file v of + -- we already have the cache but it is still called, it must be deps changed + -- clear the cache and reconsult + -- we bump the version of the cache to inform others + Just (opts, old_di) -> do + -- need to differ two kinds of invocation, one is the file is changed + -- other is the cache version bumped + deps_ok <- liftIO $ checkDependencyInfo old_di + if not deps_ok + then consultCradle file else return (opts, Map.keys old_di, [], []) - Nothing -> consultCradle file False + Nothing -> consultCradle file where catchError file hieYaml f = f `Safe.catch` \e -> do @@ -798,7 +817,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- only one cradle consult at a time -- we need to find a way to get rid of the (files, keys) _opts@(a, b, _files, _keys) <- hieYamlRuleImpl file - -- _opts@(a, b, _files, _keys) <- getOptions file pure (a, fmap toAbsolutePath b) ) From 84cea5f22d363cab8539caa199f85f050942e7a7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 23 May 2024 22:12:15 +0800 Subject: [PATCH 76/82] avoid trigger more --- ghcide/session-loader/Development/IDE/Session.hs | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1823ff61b9..7a2dafa496 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -702,7 +702,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do logWith recorder Debug $ LogSessionLoadingResult eopts - result <- UnliftIO.withMVar cradleLock $ const $ UnliftIO.async $ do + result <-UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do -- clear cache if the cradle is changed checkCache cfp $ case eopts of @@ -799,8 +799,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = 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 - -- todo make it absolute - return $ Just (normalise . toAbsolutePath <$> res) + return $ Just (normalise . toAbsolutePath <$> res) invalidateShakeCache = do void $ modifyTVar' version succ @@ -820,12 +819,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do pure (a, fmap toAbsolutePath b) ) -splitRawComponentDynFlags rawComponentDynFlags _inplace = -#if MIN_VERSION_ghc(9,3,0) - (rawComponentDynFlags, []) -#else - _removeInplacePackages fakeUid _inplace rawComponentDynFlags -#endif -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From ebb1c9e147946a287646e03c23b9ef42d4fe767d Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 24 May 2024 00:20:13 +0800 Subject: [PATCH 77/82] serialize --- .../session-loader/Development/IDE/Session.hs | 43 +++++++++---------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7a2dafa496..6628300f47 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -702,7 +702,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do logWith recorder Debug $ LogSessionLoadingResult eopts - result <-UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do + result <-do -- clear cache if the cradle is changed checkCache cfp $ case eopts of @@ -733,7 +733,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) - UnliftIO.wait result + return result sessionCacheVersionRule :: Rules () sessionCacheVersionRule = defineNoFile (cmapWithPrio LogShake recorder) $ \SessionCacheVersion -> do @@ -764,23 +764,24 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do else return (opts, Map.keys old_di, [], []) Nothing -> run - hieYamlRuleImpl file = do - hieYaml <- use_ CradleLoc file - -- check the reason we are called - v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) - catchError file hieYaml $ - case HM.lookup file v of - -- we already have the cache but it is still called, it must be deps changed - -- clear the cache and reconsult - -- we bump the version of the cache to inform others - Just (opts, old_di) -> do - -- need to differ two kinds of invocation, one is the file is changed - -- other is the cache version bumped - deps_ok <- liftIO $ checkDependencyInfo old_di - if not deps_ok - then consultCradle file - else return (opts, Map.keys old_di, [], []) - Nothing -> consultCradle file + + hieYamlRuleImpl file = checkCache file $ consultCradle file + -- hieYaml <- use_ CradleLoc file + -- -- check the reason we are called + -- v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) + -- catchError file hieYaml $ + -- case HM.lookup file v of + -- -- we already have the cache but it is still called, it must be deps changed + -- -- clear the cache and reconsult + -- -- we bump the version of the cache to inform others + -- Just (opts, old_di) -> do + -- -- need to differ two kinds of invocation, one is the file is changed + -- -- other is the cache version bumped + -- deps_ok <- liftIO $ checkDependencyInfo old_di + -- if not deps_ok + -- then consultCradle file + -- else return (opts, Map.keys old_di, [], []) + -- Nothing -> consultCradle file where catchError file hieYaml f = f `Safe.catch` \e -> do @@ -809,13 +810,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - ShakeExtras{restartShakeSession } <- getShakeExtras - IdeOptions{ optCheckProject = getCheckProject} <- getIdeOptions returnWithVersion $ \file -> do -- do -- only one cradle consult at a time -- we need to find a way to get rid of the (files, keys) - _opts@(a, b, _files, _keys) <- hieYamlRuleImpl file + _opts@(a, b, _files, _keys) <- UnliftIO.wait =<< UnliftIO.async (UnliftIO.withMVar cradleLock $ const $ hieYamlRuleImpl file) pure (a, fmap toAbsolutePath b) ) From 188aa3c571857c594489928a5d4776f0403593a8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 24 May 2024 14:26:23 +0800 Subject: [PATCH 78/82] less lock --- .../session-loader/Development/IDE/Session.hs | 60 +++++++++++++------ 1 file changed, 42 insertions(+), 18 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6628300f47..f2507fdd9c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -704,7 +704,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do result <-do -- clear cache if the cradle is changed - checkCache cfp $ + checkCacheNoLock cfp $ case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -716,23 +716,24 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do InstallationMismatch{..} -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) InstallationChecked _compileTime _ghcLibCheck -> do - liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) - result@(_, _, files, keys) <- session (hieYaml, cfp, opts, libDir) - liftIO $ when (notNull files || notNull keys) $ do - checkProject <- getCheckProject - -- think of not to restart a second time - restartShakeSession VFSUnmodified "new component" - (if checkProject then return (typecheckAll files) else mempty) - (pure keys) - return result + UnliftIO.wait =<< (UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ ( do + liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) + result@(_, _, files, keys) <- session (hieYaml, cfp, opts, libDir) + liftIO $ when (notNull files || notNull keys) $ do + checkProject <- getCheckProject + -- think of not to restart a second time + restartShakeSession VFSUnmodified "new component" + (if checkProject then return (typecheckAll files) else mempty) + (pure keys) + return result)) -- Failure case, either a cradle error or the none cradle - Left err -> do + Left err -> UnliftIO.wait =<< (UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) liftIO $ atomically $ modifyTVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[])) return result sessionCacheVersionRule :: Rules () @@ -744,11 +745,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do hieYamlRule :: Rules () hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> Just <$> hieYamlRuleImpl file - checkCache file run = do + checkCacheNoLock file run = do hieYaml <- use_ CradleLoc file -- check the reason we are called v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) - case HM.lookup file v of + res <- case HM.lookup file v of -- we already have the cache but it is still called, it must be deps changed -- clear the cache and reconsult -- we bump the version of the cache to inform others @@ -760,10 +761,33 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do then do logWith recorder Debug $ LogClearingCache file liftIO clearCache - run - else return (opts, Map.keys old_di, [], []) - Nothing -> run + return Nothing + else do + return $ Just (opts, Map.keys old_di, [], []) + Nothing -> return Nothing + maybe run return res + checkCache file run = do + hieYaml <- use_ CradleLoc file + -- check the reason we are called + v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) + res <- UnliftIO.withMVar cradleLock $ const $ case HM.lookup file v of + -- we already have the cache but it is still called, it must be deps changed + -- clear the cache and reconsult + -- we bump the version of the cache to inform others + Just (opts, old_di) -> do + -- need to differ two kinds of invocation, one is the file is changed + -- other is the cache version bumped + deps_ok <- liftIO $ checkDependencyInfo old_di + if not deps_ok + then do + logWith recorder Debug $ LogClearingCache file + liftIO clearCache + return Nothing + else do + return $ Just (opts, Map.keys old_di, [], []) + Nothing -> return Nothing + maybe run return res hieYamlRuleImpl file = checkCache file $ consultCradle file -- hieYaml <- use_ CradleLoc file @@ -814,7 +838,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- do -- only one cradle consult at a time -- we need to find a way to get rid of the (files, keys) - _opts@(a, b, _files, _keys) <- UnliftIO.wait =<< UnliftIO.async (UnliftIO.withMVar cradleLock $ const $ hieYamlRuleImpl file) + _opts@(a, b, _files, _keys) <- (hieYamlRuleImpl file) pure (a, fmap toAbsolutePath b) ) From da064cdb0409001f25cbcb7f0d80cdaa7cc946e2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 24 May 2024 14:30:32 +0800 Subject: [PATCH 79/82] lock --- .../session-loader/Development/IDE/Session.hs | 23 +------------------ 1 file changed, 1 insertion(+), 22 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f2507fdd9c..36b349ca04 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -704,7 +704,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do result <-do -- clear cache if the cradle is changed - checkCacheNoLock cfp $ + checkCache cfp $ case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -745,27 +745,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do hieYamlRule :: Rules () hieYamlRule = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \HieYaml file -> Just <$> hieYamlRuleImpl file - checkCacheNoLock file run = do - hieYaml <- use_ CradleLoc file - -- check the reason we are called - v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) - res <- case HM.lookup file v of - -- we already have the cache but it is still called, it must be deps changed - -- clear the cache and reconsult - -- we bump the version of the cache to inform others - Just (opts, old_di) -> do - -- need to differ two kinds of invocation, one is the file is changed - -- other is the cache version bumped - deps_ok <- liftIO $ checkDependencyInfo old_di - if not deps_ok - then do - logWith recorder Debug $ LogClearingCache file - liftIO clearCache - return Nothing - else do - return $ Just (opts, Map.keys old_di, [], []) - Nothing -> return Nothing - maybe run return res checkCache file run = do hieYaml <- use_ CradleLoc file From 811414f478edc5ca5433c2569e409217fa576c81 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 24 May 2024 16:20:37 +0800 Subject: [PATCH 80/82] faster --- .../session-loader/Development/IDE/Session.hs | 18 +----------------- 1 file changed, 1 insertion(+), 17 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 36b349ca04..8eac4f423f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -750,7 +750,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do hieYaml <- use_ CradleLoc file -- check the reason we are called v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) - res <- UnliftIO.withMVar cradleLock $ const $ case HM.lookup file v of + res <- case HM.lookup file v of -- we already have the cache but it is still called, it must be deps changed -- clear the cache and reconsult -- we bump the version of the cache to inform others @@ -769,22 +769,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do maybe run return res hieYamlRuleImpl file = checkCache file $ consultCradle file - -- hieYaml <- use_ CradleLoc file - -- -- check the reason we are called - -- v <- Map.findWithDefault HM.empty hieYaml <$> (liftIO$readTVarIO fileToFlags) - -- catchError file hieYaml $ - -- case HM.lookup file v of - -- -- we already have the cache but it is still called, it must be deps changed - -- -- clear the cache and reconsult - -- -- we bump the version of the cache to inform others - -- Just (opts, old_di) -> do - -- -- need to differ two kinds of invocation, one is the file is changed - -- -- other is the cache version bumped - -- deps_ok <- liftIO $ checkDependencyInfo old_di - -- if not deps_ok - -- then consultCradle file - -- else return (opts, Map.keys old_di, [], []) - -- Nothing -> consultCradle file where catchError file hieYaml f = f `Safe.catch` \e -> do From 0418e0654c8896747b9a09a09e1ebd227b406187 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 24 May 2024 16:43:23 +0800 Subject: [PATCH 81/82] faster --- ghcide/session-loader/Development/IDE/Session.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8eac4f423f..a11e841204 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -478,10 +478,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do -- Version of the mappings above version <- newTVarIO 0 - - restartKeys <- newTVarIO [] - targetFiles <- newTVarIO [] -- version of the whole rebuild cacheVersion <- newTVarIO 0 cradleLock <- newMVar () @@ -716,7 +713,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do InstallationMismatch{..} -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[], [], []) InstallationChecked _compileTime _ghcLibCheck -> do - UnliftIO.wait =<< (UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ ( do + UnliftIO.wait =<< (UnliftIO.async $ ( do liftIO $ atomicModifyIORef' cradle_files (\xs -> (fromNormalizedFilePath cfp:xs,())) result@(_, _, files, keys) <- session (hieYaml, cfp, opts, libDir) liftIO $ when (notNull files || notNull keys) $ do @@ -727,13 +724,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do (pure keys) return result)) -- Failure case, either a cradle error or the none cradle - Left err -> UnliftIO.wait =<< (UnliftIO.async $ UnliftIO.withMVar cradleLock $ const $ do + Left err -> do dep_info <- liftIO $ getDependencyInfo (maybeToList hieYaml) let res = (map (\err' -> renderCradleError err' cradle cfp) err, Nothing) - liftIO $ atomically $ modifyTVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) - liftIO $ atomically $ modifyTVar' filesMap $ HM.insert cfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[])) + liftIO $ atomically $ do + modifyTVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton cfp (res, dep_info)) + modifyTVar' filesMap $ HM.insert cfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err,[],[]) return result sessionCacheVersionRule :: Rules () From 007703336ca5a9d4257aa8b2395678e017d23d8e Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 26 May 2024 12:37:46 +0800 Subject: [PATCH 82/82] standardize dbThread --- .../session-loader/Development/IDE/Session.hs | 107 +++++++++++------- 1 file changed, 68 insertions(+), 39 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a11e841204..d6092e9bbd 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -134,6 +135,9 @@ import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat import GHC.Data.Graph.Directed +import Control.Monad.Cont (ContT (ContT, runContT), + cont, evalContT, runCont) +import Control.Monad.Trans.Class (lift) import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types @@ -393,48 +397,73 @@ makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> Hie makeWithHieDbRetryable recorder rng hieDb f = retryOnSqliteBusy recorder rng (f hieDb) --- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for --- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial --- by a worker thread using a dedicated database connection. --- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () -runWithDb recorder fp k = do - -- use non-deterministic seed because maybe multiple HLS start at same time - -- and send bursts of requests - rng <- Random.newStdGen - -- Delete the database if it has an incompatible schema version - retryOnSqliteBusy - recorder - rng - (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) - - withHieDb fp $ \writedb -> do - -- the type signature is necessary to avoid concretizing the tyvar - -- e.g. `withWriteDbRetryable initConn` without type signature will - -- instantiate tyvar `a` to `()` - let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb - withWriteDbRetryable initConn - - chan <- newTQueueIO - - withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) - where - writerThread :: WithHieDb -> IndexQueue -> IO () - writerThread withHieDbRetryable chan = do - -- Clear the index of any files that might have been deleted since the last run - _ <- withHieDbRetryable deleteMissingRealFiles - _ <- withHieDbRetryable garbageCollectTypeNames - forever $ do - l <- atomically $ readTQueue chan - -- TODO: probably should let exceptions be caught/logged/handled by top level handler - l withHieDbRetryable + +data ThreadRun input threadResource resource arg = ThreadRun { + tCreateResource :: + input -- ^ input of running + -> (threadResource -> resource -> IO ()) -- ^ function to run with reader resource + -> IO (), + tRunner -- ^ run a single action with writer resource + :: input -- ^ input of running + -> threadResource -- ^ writer resource + -> arg -- ^ argument to run + -> IO () +} + +runWithThreadRun :: ThreadRun input threadResource resource arg -> input -> (resource -> TQueue arg -> IO ()) -> IO () +runWithThreadRun ThreadRun{..} ip f = do + tCreateResource ip $ \w r -> do + q <- newTQueueIO + withAsync (writerThread w q) $ \_ -> f r q + where + writerThread r q = + forever $ do + l <- atomically $ readTQueue q + tRunner ip r l +newtype HieDbAction = HieDbAction { runHieDbAction :: WithHieDb } +sessionRestartRun :: ThreadRun (Recorder (WithPriority Log)) () () (IO ()) +sessionRestartRun = ThreadRun { + tRunner = \recorder _ _ -> do + logWith recorder Debug LogSessionLoadingChanged + , + tCreateResource = \_ f -> do f () () +} + + +dbThreadRun :: + ThreadRun + (Recorder (WithPriority Log), FilePath) + HieDbAction + HieDbAction + (((HieDb -> IO a) -> IO a) -> IO ()) +dbThreadRun = ThreadRun { + tRunner = \(recorder, _fp) withWriter l -> l (runHieDbAction withWriter) `Safe.catch` \e@SQLError{} -> do logWith recorder Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \f -> do logWith recorder Error $ LogHieDbWriterThreadException f + , + tCreateResource = \(recorder, fp) f -> do + rng <- Random.newStdGen + retryOnSqliteBusy + recorder + rng + (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) + evalContT $ do + writedb <- ContT $ withHieDb fp + readDb <- ContT $ withHieDb fp + let withWriteDbRetryable :: WithHieDb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb + liftIO $ withWriteDbRetryable initConn + lift $ f (HieDbAction withWriteDbRetryable) (HieDbAction (makeWithHieDbRetryable recorder rng readDb)) +} +-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for +-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial +-- by a worker thread using a dedicated database connection. +-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy +runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () +runWithDb recorder fp k = runWithThreadRun dbThreadRun (recorder, fp) (\db chan -> k (runHieDbAction db) chan) getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do