From 4b33075be23470e718d987a108a89e1734dfced2 Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Fri, 3 Jul 2026 17:13:52 +0200 Subject: [PATCH 1/3] adding whole-project loading --- cabal.project | 2 +- ghcide/ghcide.cabal | 2 +- .../session-loader/Development/IDE/Session.hs | 7 +++-- .../Development/IDE/Session/Implicit.hs | 6 ++-- hls-plugin-api/src/Ide/Plugin/Config.hs | 25 +++++++++------- hls-plugin-api/src/Ide/Types.hs | 29 +++++++++++++++---- stack-lts24.yaml | 2 +- stack.yaml | 2 +- .../schema/ghc910/default-config.golden.json | 4 +-- .../schema/ghc912/default-config.golden.json | 4 +-- .../schema/ghc914/default-config.golden.json | 4 +-- .../schema/ghc96/default-config.golden.json | 4 +-- .../schema/ghc98/default-config.golden.json | 4 +-- 13 files changed, 59 insertions(+), 36 deletions(-) diff --git a/cabal.project b/cabal.project index d9085d43ca..c10245eaa0 100644 --- a/cabal.project +++ b/cabal.project @@ -6,7 +6,7 @@ packages: ./hls-plugin-api ./hls-test-utils -index-state: 2026-04-16T00:00:00Z +index-state: 2026-07-03T13:55:55Z tests: True test-show-details: direct diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 01b694ccbc..d84fc2b0c7 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -74,7 +74,7 @@ library , Glob , haddock-library >=1.8 && <1.12 , hashable - , hie-bios ^>= 0.19.0 + , hie-bios ^>= 0.20.0 , hiedb ^>= 0.8.0.0 , hls-graph == 2.14.0.0 , hls-plugin-api == 2.14.0.0 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7e1a062a7a..e3aaf1f087 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1040,7 +1040,7 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" -- Start off by getting the session options logWith recorder Debug $ LogCradle cradle - cradleRes <- HieBios.getCompilerOptions file loadStyle cradle + cradleRes <- HieBios.getCompilerOptions (TargetWithContext file old_fps) loadStyle cradle case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir @@ -1061,8 +1061,9 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do where loadStyle = case loadConfig of - PreferSingleComponentLoading -> LoadFile - PreferMultiComponentLoading -> LoadWithContext old_fps + PreferSingleComponentLoading -> LoadFile + PreferMultiComponentLoading -> LoadFileWithContext + PreferMultiWholeProjectLoading -> LoadUnitsFromCradle -- ---------------------------------------------------------------------------- -- Utilities diff --git a/ghcide/session-loader/Development/IDE/Session/Implicit.hs b/ghcide/session-loader/Development/IDE/Session/Implicit.hs index c7a6402a9f..06c2a70ae4 100644 --- a/ghcide/session-loader/Development/IDE/Session/Implicit.hs +++ b/ghcide/session-loader/Development/IDE/Session/Implicit.hs @@ -78,12 +78,12 @@ stackCradle fp = do pkgsWithComps <- liftIO $ catMaybes <$> mapM (nestedPkg fp) pkgs let yaml = fp "stack.yaml" pure $ (,fp) $ case pkgsWithComps of - [] -> Stack (StackType Nothing (Just yaml)) + [] -> Stack (StackType Nothing (Just yaml) Nothing) ps -> StackMulti mempty $ do Package n cs <- ps c <- cs let (prefix, comp) = Implicit.stackComponent n c - pure (prefix, StackType (Just comp) (Just yaml)) + pure (prefix, StackType (Just comp) (Just yaml) Nothing) -- | By default, we generate a simple cabal cradle which is equivalent to the -- following hie.yaml: @@ -95,7 +95,7 @@ stackCradle fp = do -- -- Note, this only works reliable for reasonably modern cabal versions >= 3.2. simpleCabalCradle :: FilePath -> (CradleTree a, FilePath) -simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing, fp) +simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing Nothing, fp) cabalExecutable :: MaybeT IO FilePath cabalExecutable = MaybeT $ findExecutable "cabal" diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index d7b5638145..2a7e3fa931 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -10,16 +10,17 @@ module Ide.Plugin.Config , CheckParents(..) ) where -import Control.Lens (preview) -import Data.Aeson hiding (Error) -import qualified Data.Aeson as A -import Data.Aeson.Lens (_String) -import qualified Data.Aeson.Types as A +import Control.Applicative +import Control.Lens (preview) +import Data.Aeson hiding (Error) +import qualified Data.Aeson as A +import Data.Aeson.Lens (_String) +import qualified Data.Aeson.Types as A import Data.Default -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import GHC.Exts (toList) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import GHC.Exts (toList) import Ide.Types -- --------------------------------------------------------------------- @@ -42,11 +43,15 @@ parseConfig idePlugins defValue = A.withObject "settings" $ \o -> <*> o .:? "formattingProvider" .!= formattingProvider defValue <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue - <*> o .:? "sessionLoading" .!= sessionLoading defValue + <*> loadingPref o <*> o .:? "linkSourceTo" .!= linkSourceTo defValue <*> o .:? "linkDocTo" .!= linkDocTo defValue <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue + where + loadingPref o = + (o .:? "componentsLoading" + <|> o .:? "sessionLoading") .!= sessionLoading defValue -- | Parse the 'PluginConfig'. -- Since we need to fall back to default values if we do not find one in the input, diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 63e9d7ea65..3b0e9bcc37 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -78,6 +78,7 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Kind (Type) +import qualified Data.List as List import Data.List.Extra (find, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map @@ -192,7 +193,7 @@ instance ToJSON Config where , "formattingProvider" .= formattingProvider , "cabalFormattingProvider" .= cabalFormattingProvider , "maxCompletions" .= maxCompletions - , "sessionLoading" .= sessionLoading + , "componentsLoading" .= sessionLoading , "linkSourceTo" .= linkSourceTo , "linkDocTo" .= linkDocTo , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins @@ -240,24 +241,40 @@ data SessionLoadingPreferenceConfig -- -- The cradle can decide how to handle these situations, and whether -- to honour the preference at all. + | PreferMultiWholeProjectLoading + -- ^ Prefer loading all the components specified in the cradle, if possible. deriving stock (Eq, Ord, Show, Generic) instance Pretty SessionLoadingPreferenceConfig where - pretty PreferSingleComponentLoading = "Prefer Single Component Loading" - pretty PreferMultiComponentLoading = "Prefer Multiple Components Loading" + pretty PreferSingleComponentLoading = "Prefer Single Component Loading" + pretty PreferMultiComponentLoading = "Prefer Multiple Components Loading" + pretty PreferMultiWholeProjectLoading = "Prefer Whole Project Loading" instance ToJSON SessionLoadingPreferenceConfig where toJSON PreferSingleComponentLoading = - String "singleComponent" + String "single" toJSON PreferMultiComponentLoading = - String "multipleComponents" + String "multi: needed-only" + toJSON PreferMultiWholeProjectLoading = + String "multi: whole-project" instance FromJSON SessionLoadingPreferenceConfig where parseJSON (String val) = case val of "singleComponent" -> pure PreferSingleComponentLoading + "single" -> pure PreferSingleComponentLoading "multipleComponents" -> pure PreferMultiComponentLoading + "multi: needed-only" -> pure PreferMultiComponentLoading + "multi: whole-project" -> pure PreferMultiWholeProjectLoading _ -> A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " - (A.parseFail $ "Expected one of \"singleComponent\" or \"multipleComponents\" but got " <> T.unpack val ) + (A.parseFail $ unwords ["Expected one of", expected, "but got", T.unpack val] ) + where + expected = concat ["[", List.intercalate ", " fields, "]"] + fields = map (show @String) + ["single", "multi: only-needed", "multi: whole-project"] + ++ + [ show @String old_value ++ " (deprecated)" + | old_value <- ["singleComponent","multiComponent"] + ] parseJSON o = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " (A.typeMismatch "String" o) diff --git a/stack-lts24.yaml b/stack-lts24.yaml index e80d1eb3c6..74936d0ab1 100644 --- a/stack-lts24.yaml +++ b/stack-lts24.yaml @@ -21,7 +21,7 @@ extra-deps: - hiedb-0.8.0.0 - hie-compat-0.3.1.2 - implicit-hie-0.1.4.0 - - hie-bios-0.19.0 + - hie-bios-0.20.0 - hw-fingertree-0.1.2.1 - monad-dijkstra-0.1.1.5 - unordered-containers-0.2.21 diff --git a/stack.yaml b/stack.yaml index cd1b6873d9..610873fa50 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,7 +22,7 @@ extra-deps: - hiedb-0.8.0.0 - hie-compat-0.3.1.2 - implicit-hie-0.1.4.0 - - hie-bios-0.19.0 + - hie-bios-0.20.0 - hw-fingertree-0.1.2.1 - monad-dijkstra-0.1.1.5 - unordered-containers-0.2.21 diff --git a/test/testdata/schema/ghc910/default-config.golden.json b/test/testdata/schema/ghc910/default-config.golden.json index 3096374404..d71c1179a8 100644 --- a/test/testdata/schema/ghc910/default-config.golden.json +++ b/test/testdata/schema/ghc910/default-config.golden.json @@ -2,6 +2,7 @@ "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, + "componentsLoading": "multi: needed-only", "formattingProvider": "ormolu", "linkDocTo": "LinkToHackage", "linkSourceTo": "LinkToHackage", @@ -159,6 +160,5 @@ "stan": { "globalOn": false } - }, - "sessionLoading": "multipleComponents" + } } diff --git a/test/testdata/schema/ghc912/default-config.golden.json b/test/testdata/schema/ghc912/default-config.golden.json index 4371b29094..72c1822148 100644 --- a/test/testdata/schema/ghc912/default-config.golden.json +++ b/test/testdata/schema/ghc912/default-config.golden.json @@ -2,6 +2,7 @@ "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, + "componentsLoading": "multi: needed-only", "formattingProvider": "ormolu", "linkDocTo": "LinkToHackage", "linkSourceTo": "LinkToHackage", @@ -163,6 +164,5 @@ "splice": { "globalOn": true } - }, - "sessionLoading": "multipleComponents" + } } diff --git a/test/testdata/schema/ghc914/default-config.golden.json b/test/testdata/schema/ghc914/default-config.golden.json index 0f68207b81..d59cb5be44 100644 --- a/test/testdata/schema/ghc914/default-config.golden.json +++ b/test/testdata/schema/ghc914/default-config.golden.json @@ -2,6 +2,7 @@ "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, + "componentsLoading": "multi: needed-only", "formattingProvider": "ormolu", "linkDocTo": "LinkToHackage", "linkSourceTo": "LinkToHackage", @@ -145,6 +146,5 @@ "splice": { "globalOn": true } - }, - "sessionLoading": "multipleComponents" + } } diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index f2c28d08f5..0c7fdfa91b 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -2,6 +2,7 @@ "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, + "componentsLoading": "multi: needed-only", "formattingProvider": "ormolu", "linkDocTo": "LinkToHackage", "linkSourceTo": "LinkToHackage", @@ -166,6 +167,5 @@ "stan": { "globalOn": false } - }, - "sessionLoading": "multipleComponents" + } } diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index f2c28d08f5..0c7fdfa91b 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -2,6 +2,7 @@ "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, + "componentsLoading": "multi: needed-only", "formattingProvider": "ormolu", "linkDocTo": "LinkToHackage", "linkSourceTo": "LinkToHackage", @@ -166,6 +167,5 @@ "stan": { "globalOn": false } - }, - "sessionLoading": "multipleComponents" + } } From b2c7eada89abd46994ee816758900e475f43d65f Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Tue, 7 Jul 2026 11:52:06 +0200 Subject: [PATCH 2/3] run multi tests with whole-project too --- ghcide-test/exe/CradleTests.hs | 163 +++++++++++++++++++++++---------- 1 file changed, 114 insertions(+), 49 deletions(-) diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs index ac9d42c483..d733632615 100644 --- a/ghcide-test/exe/CradleTests.hs +++ b/ghcide-test/exe/CradleTests.hs @@ -37,28 +37,36 @@ import Language.LSP.Test import System.FilePath import Test.Hls (TestConfig (..), def, runSessionWithTestConfig, - waitForBuildQueue) + waitForBuildQueue, setHlsConfig) import Test.Hls.FileSystem import Test.Hls.Util (EnvSpec (..), OS (..), ignoreInEnv) import Test.Tasty import Test.Tasty.HUnit +import Control.Monad (when) tests :: TestTree tests = testGroup "cradle" - [testGroup "dependencies" [sessionDepsArePickedUp] - ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + [testGroup "dependencies" $ bothLoadings1 sessionDepsArePickedUp + ,testGroup "ignore-fatal" $ bothLoadings1 ignoreFatalWarning + ,testGroup "loading" $ bothLoadings $ \initM -> [loadCradleOnlyonce initM, retryFailedCradle initM] ,testGroup "regression.batch" batchLoadRegressionTests ,testGroup "multi" (multiTests "multi") ,testGroup "multi-unit" (multiTests "multi-unit") - ,testGroup "sub-directory" [simpleSubDirectoryTest] - ,testGroup "multi-unit-rexport" [multiRexportTest] + ,testGroup "sub-directory" $ bothLoadings1 simpleSubDirectoryTest + ,testGroup "multi-unit-rexport" $ bothLoadings1 multiRexportTest ] -loadCradleOnlyonce :: TestTree -loadCradleOnlyonce = testGroup "load cradle only once" +-- | Test both with the default `componentsLoading` and WholeProject. +bothLoadings :: (Session () -> [TestTree]) -> [TestTree] +bothLoadings m = [testGroup "default" (m (return ())) + , testGroup "whole-project" (m setWholeProjectLoading)] +bothLoadings1 :: (Session () -> TestTree) -> [TestTree] +bothLoadings1 m = bothLoadings $ \ initM -> [m initM] + +loadCradleOnlyonce :: Session () -> TestTree +loadCradleOnlyonce initM = testGroup "load cradle only once" [ testWithDummyPluginEmpty' "implicit" implicit , testWithDummyPluginEmpty' "direct" direct ] @@ -69,6 +77,7 @@ loadCradleOnlyonce = testGroup "load cradle only once" test dir implicit dir = test dir test _dir = do + initM doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 1 @@ -79,8 +88,9 @@ loadCradleOnlyonce = testGroup "load cradle only once" msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 0 -retryFailedCradle :: TestTree -retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do +retryFailedCradle :: Session () -> TestTree +retryFailedCradle initM = testWithDummyPluginEmpty' "retry failed" $ \dir -> do + initM -- The false cradle always fails let hieContents = "cradle: {bios: {shell: \"false\"}}" hiePath = dir "hie.yaml" @@ -108,16 +118,18 @@ cradleLoadedMessage = satisfy $ \case cradleLoadedMethod :: String cradleLoadedMethod = "ghcide/cradle/loaded" -ignoreFatalWarning :: TestTree -ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do +ignoreFatalWarning :: Session () -> TestTree +ignoreFatalWarning initM = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do + initM let srcPath = dir "IgnoreFatal.hs" src <- liftIO $ readFileUtf8 srcPath _ <- createDoc srcPath "haskell" src expectNoMoreDiagnostics 5 -simpleSubDirectoryTest :: TestTree -simpleSubDirectoryTest = +simpleSubDirectoryTest :: Session () -> TestTree +simpleSubDirectoryTest initM = testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do + initM let mainPath = dir "a/src/Main.hs" mainSource <- liftIO $ readFileUtf8 mainPath _mdoc <- createDoc mainPath "haskell" mainSource @@ -127,18 +139,31 @@ simpleSubDirectoryTest = expectNoMoreDiagnostics 0.5 multiTests :: FilePath -> [TestTree] -multiTests dir = - [ simpleMultiTest dir - , simpleMultiTest2 dir - , simpleMultiTest3 dir - , simpleMultiDefTest dir - ] +multiTests odir = + [ testGroup "default" $ tests (return ()) + , testGroup "whole-project" $ tests setWholeProjectLoading + ] + where + tests initM = + [ ignoreForWindows testName $ testCase testName $ runWithExtraFiles odir $ \dir -> initM >> test dir + | (name,test) <- + [ ("test",simpleMultiTest) + , ("test2",simpleMultiTest2) + , ("test3",simpleMultiTest3) + , ("def-test",simpleMultiDefTest) + ] + , + let testName = multiTestName odir name + ] + ignoreForWindows testName + | testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270" + | otherwise = id multiTestName :: FilePath -> String -> String multiTestName dir name = "simple-" ++ dir ++ "-" ++ name -simpleMultiTest :: FilePath -> TestTree -simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do +simpleMultiTest :: FilePath -> Session () +simpleMultiTest = \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" adoc <- openDoc aPath "haskell" @@ -153,8 +178,8 @@ simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtra expectNoMoreDiagnostics 0.5 -- Like simpleMultiTest but open the files in the other order -simpleMultiTest2 :: FilePath -> TestTree -simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExtraFiles variant $ \dir -> do +simpleMultiTest2 :: FilePath -> Session () +simpleMultiTest2 = \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" bdoc <- openDoc bPath "haskell" @@ -167,9 +192,8 @@ simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExt expectNoMoreDiagnostics 0.5 -- Now with 3 components -simpleMultiTest3 :: FilePath -> TestTree -simpleMultiTest3 variant = - testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \dir -> do +simpleMultiTest3 :: FilePath -> Session () +simpleMultiTest3 = \ dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" cPath = dir "c/C.hs" @@ -273,12 +297,31 @@ batchLoadRegressionTests = , testCase "s1-no-stale-outcomes-across-restart-paths" $ runWithExtraFilesMultiComponent "multi" regressionNoStaleOutcomesOnRestart ] + ++ [ testGroup "whole-project" + [ testCase "m1-open-a-then-b-batch-pending-and-success" $ + runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenAThenB + , testCase "m2-open-b-then-a-batch-pending-and-success" $ + runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenBThenA + , testCase "m3-open-b-then-a-then-c-batch-pending-and-success" $ + runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenBThenAThenC + , testCase "f1-batch-pending-failure-does-not-isolate-broken-component" $ + runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" regressionBatchFailureDoesNotIsolateBrokenComponent + , testCase "f2-failed-file-keeps-failing-until-cradle-fix" $ + runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" $ regressionFailedFileKeepsFailingUntilFix' False + , testCase "r1-failed-file-recovers-after-cradle-fix" $ + runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" regressionFailedFileRecoversAfterFix + , testCase "s1-no-stale-outcomes-across-restart-paths" $ + runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" $ regressionNoStaleOutcomesOnRestart' False + ]] runWithExtraFilesMultiComponent :: String -> (FilePath -> Session a) -> IO a -runWithExtraFilesMultiComponent dirName action = do +runWithExtraFilesMultiComponent = runWithExtraFilesMultiComponent' PreferMultiComponentLoading + +runWithExtraFilesMultiComponent' :: SessionLoadingPreferenceConfig -> String -> (FilePath -> Session a) -> IO a +runWithExtraFilesMultiComponent' sesLoading dirName action = do let vfs = mkIdeTestFs [copyDir dirName] lspConfig :: Config - lspConfig = def { sessionLoading = PreferMultiComponentLoading } + lspConfig = def { sessionLoading = sesLoading } conf :: TestConfig () conf = def { testPluginDescriptor = dummyPlugin @@ -321,6 +364,11 @@ assertTypeCheckFailure doc msg = do WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool msg (not ideResultSuccess) +setWholeProjectLoading :: Session () +setWholeProjectLoading = do + setIgnoringConfigurationRequests False + setHlsConfig def{sessionLoading = PreferMultiWholeProjectLoading} + regressionBatchFailureIsolatesBrokenFile :: FilePath -> Session () regressionBatchFailureIsolatesBrokenFile dir = do writeBrokenMultiHieYaml dir @@ -333,8 +381,24 @@ regressionBatchFailureIsolatesBrokenFile dir = do liftIO $ assertBool "A should typecheck when B cradle mapping is broken" (ideResultSuccess aRes) liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes) +-- | With whole-project loading a failed component blocks the whole session. +regressionBatchFailureDoesNotIsolateBrokenComponent :: FilePath -> Session () +regressionBatchFailureDoesNotIsolateBrokenComponent dir = do + writeBrokenMultiHieYaml dir + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" + _ <- waitForBuildQueue + [aRes, bRes] <- waitForTypeChecksBatched [adoc, bdoc] + liftIO $ assertBool "A should not typecheck when B cradle mapping is broken" (not $ ideResultSuccess aRes) + liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes) + regressionFailedFileKeepsFailingUntilFix :: FilePath -> Session () -regressionFailedFileKeepsFailingUntilFix dir = do +regressionFailedFileKeepsFailingUntilFix = regressionFailedFileKeepsFailingUntilFix' True + +regressionFailedFileKeepsFailingUntilFix' :: Bool -> FilePath -> Session () +regressionFailedFileKeepsFailingUntilFix' isolated dir = do writeBrokenMultiHieYaml dir let aPath = dir "a/A.hs" bPath = dir "b/B.hs" @@ -347,10 +411,11 @@ regressionFailedFileKeepsFailingUntilFix dir = do [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"] assertTypeCheckFailure bdoc "B should keep failing until the cradle is fixed" - adoc <- openDoc aPath "haskell" - cdoc <- openDoc cPath "haskell" - assertTypeCheckSuccess adoc "A should still typecheck while B remains broken" - assertTypeCheckSuccess cdoc "C should still typecheck while B remains broken" + when isolated $ do + adoc <- openDoc aPath "haskell" + cdoc <- openDoc cPath "haskell" + assertTypeCheckSuccess adoc "A should still typecheck while B remains broken" + assertTypeCheckSuccess cdoc "C should still typecheck while B remains broken" regressionFailedFileRecoversAfterFix :: FilePath -> Session () regressionFailedFileRecoversAfterFix dir = do @@ -371,7 +436,10 @@ regressionFailedFileRecoversAfterFix dir = do assertTypeCheckSuccess bdoc "B should recover after restoring the cradle" regressionNoStaleOutcomesOnRestart :: FilePath -> Session () -regressionNoStaleOutcomesOnRestart dir = do +regressionNoStaleOutcomesOnRestart = regressionNoStaleOutcomesOnRestart' True + +regressionNoStaleOutcomesOnRestart' :: Bool -> FilePath -> Session () +regressionNoStaleOutcomesOnRestart' isolated dir = do let hiePath = dir "hie.yaml" aPath = dir "a/A.hs" bPath = dir "b/B.hs" @@ -382,8 +450,9 @@ regressionNoStaleOutcomesOnRestart dir = do bdoc <- openDoc bPath "haskell" assertTypeCheckFailure bdoc "B should fail before cradle fix" - adoc <- openDoc aPath "haskell" - assertTypeCheckSuccess adoc "A should remain healthy while B is broken" + when isolated $ do + adoc <- openDoc aPath "haskell" + assertTypeCheckSuccess adoc "A should remain healthy while B is broken" liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie) notifyHieYamlChanged dir @@ -397,9 +466,8 @@ regressionNoStaleOutcomesOnRestart dir = do assertTypeCheckSuccess bdoc "B should not keep stale failure after cradle restart" -- Like simpleMultiTest but open the files in component 'a' in a separate session -simpleMultiDefTest :: FilePath -> TestTree -simpleMultiDefTest variant = ignoreForWindows $ testCase testName $ - runWithExtraFiles variant $ \dir -> do +simpleMultiDefTest :: FilePath -> Session () +simpleMultiDefTest = \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" adoc <- openDoc aPath "haskell" @@ -411,15 +479,11 @@ simpleMultiDefTest variant = ignoreForWindows $ testCase testName $ let fooL = mkL (adoc ^. L.uri) 2 0 2 3 checkDefs locs (pure [fooL]) expectNoMoreDiagnostics 0.5 - where - testName = multiTestName variant "def-test" - ignoreForWindows - | testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270" - | otherwise = id -multiRexportTest :: TestTree -multiRexportTest = +multiRexportTest :: Session () -> TestTree +multiRexportTest initM = testCase "multi-unit-reexport-test" $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do + initM let cPath = dir "c/C.hs" cdoc <- openDoc cPath "haskell" WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc @@ -429,10 +493,11 @@ multiRexportTest = checkDefs locs (pure [fooL]) expectNoMoreDiagnostics 0.5 -sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testWithDummyPluginEmpty' +sessionDepsArePickedUp :: Session () -> TestTree +sessionDepsArePickedUp initM = testWithDummyPluginEmpty' "session-deps-are-picked-up" $ \dir -> do + initM liftIO $ atomicFileWriteStringUTF8 (dir "hie.yaml") From 8c08f37f96e1f61dce9998257b91ac7d69d7d1ee Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Tue, 7 Jul 2026 13:55:21 +0200 Subject: [PATCH 3/3] consistent naming --- ghcide-test/exe/CradleTests.hs | 4 +- .../session-loader/Development/IDE/Session.hs | 10 ++--- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- hls-plugin-api/src/Ide/Plugin/Config.hs | 2 +- hls-plugin-api/src/Ide/Types.hs | 40 +++++++++++-------- 5 files changed, 32 insertions(+), 26 deletions(-) diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs index d733632615..7c2693dc12 100644 --- a/ghcide-test/exe/CradleTests.hs +++ b/ghcide-test/exe/CradleTests.hs @@ -321,7 +321,7 @@ runWithExtraFilesMultiComponent' :: SessionLoadingPreferenceConfig -> String -> runWithExtraFilesMultiComponent' sesLoading dirName action = do let vfs = mkIdeTestFs [copyDir dirName] lspConfig :: Config - lspConfig = def { sessionLoading = sesLoading } + lspConfig = def { componentsLoading = sesLoading } conf :: TestConfig () conf = def { testPluginDescriptor = dummyPlugin @@ -367,7 +367,7 @@ assertTypeCheckFailure doc msg = do setWholeProjectLoading :: Session () setWholeProjectLoading = do setIgnoringConfigurationRequests False - setHlsConfig def{sessionLoading = PreferMultiWholeProjectLoading} + setHlsConfig def{componentsLoading = PreferMultiWholeProjectLoading} regressionBatchFailureIsolatesBrokenFile :: FilePath -> Session () regressionBatchFailureIsolatesBrokenFile dir = do diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index e3aaf1f087..a65f95f94c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -71,7 +71,7 @@ import Ide.Logger (Pretty (pretty), vcat, viaShow, (<+>)) import Ide.Types (Config, SessionLoadingPreferenceConfig (..), - sessionLoading) + componentsLoading) import Language.LSP.Protocol.Message import Language.LSP.Server import System.Directory @@ -599,11 +599,11 @@ didSessionLoadingPreferenceConfigChange s = do mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar case mLoadingConfig of Nothing -> do - liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + liftIO $ writeVar biosSessionLoadingVar (Just (componentsLoading clientConfig)) pure False Just loadingConfig -> do - liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure (loadingConfig /= sessionLoading clientConfig) + liftIO $ writeVar biosSessionLoadingVar (Just (componentsLoading clientConfig)) + pure (loadingConfig /= componentsLoading clientConfig) newSessionState :: IO SessionState newSessionState = do @@ -1018,7 +1018,7 @@ loadCradleWithNotifications recorder sessionState hieYaml cfp = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - sessionPref <- asks (sessionLoading . sessionClientConfig) + sessionPref <- asks (componentsLoading . sessionClientConfig) extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp -- Start loading the file! eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 9ae8ee370c..7f47b8473e 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -734,7 +734,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do [ B.encode (hash (sessionVersion res)) -- When the session version changes, reload all session -- hsc env sessions - , B.encode (show (sessionLoading config)) + , B.encode (show (componentsLoading config)) -- The loading config affects session loading. -- Invalidate all build nodes. -- Changing the session loading config will increment diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 2a7e3fa931..9ece58dde6 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -51,7 +51,7 @@ parseConfig idePlugins defValue = A.withObject "settings" $ \o -> where loadingPref o = (o .:? "componentsLoading" - <|> o .:? "sessionLoading") .!= sessionLoading defValue + <|> o .:? "sessionLoading") .!= componentsLoading defValue -- | Parse the 'PluginConfig'. -- Since we need to fall back to default values if we do not find one in the input, diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 3b0e9bcc37..02b455be5e 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -180,7 +180,7 @@ data Config = , formattingProvider :: !T.Text , cabalFormattingProvider :: !T.Text , maxCompletions :: !Int - , sessionLoading :: !SessionLoadingPreferenceConfig + , componentsLoading :: !SessionLoadingPreferenceConfig , linkSourceTo :: !OptLinkTo , linkDocTo :: !OptLinkTo , plugins :: !(Map.Map PluginId PluginConfig) @@ -193,7 +193,7 @@ instance ToJSON Config where , "formattingProvider" .= formattingProvider , "cabalFormattingProvider" .= cabalFormattingProvider , "maxCompletions" .= maxCompletions - , "componentsLoading" .= sessionLoading + , "componentsLoading" .= componentsLoading , "linkSourceTo" .= linkSourceTo , "linkDocTo" .= linkDocTo , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins @@ -209,7 +209,7 @@ instance Default Config where -- , cabalFormattingProvider = "cabal-fmt" -- this string value needs to kept in sync with the value provided in HlsPlugins , maxCompletions = 40 - , sessionLoading = PreferMultiComponentLoading + , componentsLoading = PreferMultiComponentLoading , linkSourceTo = LinkToHackage , linkDocTo = LinkToHackage , plugins = mempty @@ -250,30 +250,36 @@ instance Pretty SessionLoadingPreferenceConfig where pretty PreferMultiComponentLoading = "Prefer Multiple Components Loading" pretty PreferMultiWholeProjectLoading = "Prefer Whole Project Loading" +-- | Labels for @SessionLoadingPreferenceConfig@ json format. +singleComponent, multipleComponents, single, multiNeededOnly, multiWholeProject :: T.Text +singleComponent = "singleComponent" +multipleComponents = "multipleComponents" +single = "single" +multiNeededOnly = "multi: needed-only" +multiWholeProject = "multi: whole-project" + instance ToJSON SessionLoadingPreferenceConfig where toJSON PreferSingleComponentLoading = - String "single" + String single toJSON PreferMultiComponentLoading = - String "multi: needed-only" + String multiNeededOnly toJSON PreferMultiWholeProjectLoading = - String "multi: whole-project" + String multiWholeProject instance FromJSON SessionLoadingPreferenceConfig where - parseJSON (String val) = case val of - "singleComponent" -> pure PreferSingleComponentLoading - "single" -> pure PreferSingleComponentLoading - "multipleComponents" -> pure PreferMultiComponentLoading - "multi: needed-only" -> pure PreferMultiComponentLoading - "multi: whole-project" -> pure PreferMultiWholeProjectLoading - _ -> A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " + parseJSON (String val) + | val `elem` [singleComponent, single] = pure PreferSingleComponentLoading + | val `elem` [multipleComponents, multiNeededOnly] = pure PreferMultiComponentLoading + | val == multiWholeProject = pure PreferMultiWholeProjectLoading + | otherwise = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " (A.parseFail $ unwords ["Expected one of", expected, "but got", T.unpack val] ) where expected = concat ["[", List.intercalate ", " fields, "]"] - fields = map (show @String) - ["single", "multi: only-needed", "multi: whole-project"] + fields = map show + [single, multiNeededOnly, multiWholeProject] ++ - [ show @String old_value ++ " (deprecated)" - | old_value <- ["singleComponent","multiComponent"] + [ show old_value ++ " (deprecated)" + | old_value <- [singleComponent,multipleComponents] ] parseJSON o = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " (A.typeMismatch "String" o)