Skip to content

Commit b2c7ead

Browse files
SaizanSaizan
committed
run multi tests with whole-project too
1 parent 4b33075 commit b2c7ead

1 file changed

Lines changed: 114 additions & 49 deletions

File tree

‎ghcide-test/exe/CradleTests.hs‎

Lines changed: 114 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -37,28 +37,36 @@ import Language.LSP.Test
3737
import System.FilePath
3838
import Test.Hls (TestConfig (..), def,
3939
runSessionWithTestConfig,
40-
waitForBuildQueue)
40+
waitForBuildQueue, setHlsConfig)
4141
import Test.Hls.FileSystem
4242
import Test.Hls.Util (EnvSpec (..), OS (..),
4343
ignoreInEnv)
4444
import Test.Tasty
4545
import Test.Tasty.HUnit
46+
import Control.Monad (when)
4647

4748

4849
tests :: TestTree
4950
tests = testGroup "cradle"
50-
[testGroup "dependencies" [sessionDepsArePickedUp]
51-
,testGroup "ignore-fatal" [ignoreFatalWarning]
52-
,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
51+
[testGroup "dependencies" $ bothLoadings1 sessionDepsArePickedUp
52+
,testGroup "ignore-fatal" $ bothLoadings1 ignoreFatalWarning
53+
,testGroup "loading" $ bothLoadings $ \initM -> [loadCradleOnlyonce initM, retryFailedCradle initM]
5354
,testGroup "regression.batch" batchLoadRegressionTests
5455
,testGroup "multi" (multiTests "multi")
5556
,testGroup "multi-unit" (multiTests "multi-unit")
56-
,testGroup "sub-directory" [simpleSubDirectoryTest]
57-
,testGroup "multi-unit-rexport" [multiRexportTest]
57+
,testGroup "sub-directory" $ bothLoadings1 simpleSubDirectoryTest
58+
,testGroup "multi-unit-rexport" $ bothLoadings1 multiRexportTest
5859
]
5960

60-
loadCradleOnlyonce :: TestTree
61-
loadCradleOnlyonce = testGroup "load cradle only once"
61+
-- | Test both with the default `componentsLoading` and WholeProject.
62+
bothLoadings :: (Session () -> [TestTree]) -> [TestTree]
63+
bothLoadings m = [testGroup "default" (m (return ()))
64+
, testGroup "whole-project" (m setWholeProjectLoading)]
65+
bothLoadings1 :: (Session () -> TestTree) -> [TestTree]
66+
bothLoadings1 m = bothLoadings $ \ initM -> [m initM]
67+
68+
loadCradleOnlyonce :: Session () -> TestTree
69+
loadCradleOnlyonce initM = testGroup "load cradle only once"
6270
[ testWithDummyPluginEmpty' "implicit" implicit
6371
, testWithDummyPluginEmpty' "direct" direct
6472
]
@@ -69,6 +77,7 @@ loadCradleOnlyonce = testGroup "load cradle only once"
6977
test dir
7078
implicit dir = test dir
7179
test _dir = do
80+
initM
7281
doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
7382
msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
7483
liftIO $ length msgs @?= 1
@@ -79,8 +88,9 @@ loadCradleOnlyonce = testGroup "load cradle only once"
7988
msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
8089
liftIO $ length msgs @?= 0
8190

82-
retryFailedCradle :: TestTree
83-
retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
91+
retryFailedCradle :: Session () -> TestTree
92+
retryFailedCradle initM = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
93+
initM
8494
-- The false cradle always fails
8595
let hieContents = "cradle: {bios: {shell: \"false\"}}"
8696
hiePath = dir </> "hie.yaml"
@@ -108,16 +118,18 @@ cradleLoadedMessage = satisfy $ \case
108118
cradleLoadedMethod :: String
109119
cradleLoadedMethod = "ghcide/cradle/loaded"
110120

111-
ignoreFatalWarning :: TestTree
112-
ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do
121+
ignoreFatalWarning :: Session () -> TestTree
122+
ignoreFatalWarning initM = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do
123+
initM
113124
let srcPath = dir </> "IgnoreFatal.hs"
114125
src <- liftIO $ readFileUtf8 srcPath
115126
_ <- createDoc srcPath "haskell" src
116127
expectNoMoreDiagnostics 5
117128

118-
simpleSubDirectoryTest :: TestTree
119-
simpleSubDirectoryTest =
129+
simpleSubDirectoryTest :: Session () -> TestTree
130+
simpleSubDirectoryTest initM =
120131
testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do
132+
initM
121133
let mainPath = dir </> "a/src/Main.hs"
122134
mainSource <- liftIO $ readFileUtf8 mainPath
123135
_mdoc <- createDoc mainPath "haskell" mainSource
@@ -127,18 +139,31 @@ simpleSubDirectoryTest =
127139
expectNoMoreDiagnostics 0.5
128140

129141
multiTests :: FilePath -> [TestTree]
130-
multiTests dir =
131-
[ simpleMultiTest dir
132-
, simpleMultiTest2 dir
133-
, simpleMultiTest3 dir
134-
, simpleMultiDefTest dir
135-
]
142+
multiTests odir =
143+
[ testGroup "default" $ tests (return ())
144+
, testGroup "whole-project" $ tests setWholeProjectLoading
145+
]
146+
where
147+
tests initM =
148+
[ ignoreForWindows testName $ testCase testName $ runWithExtraFiles odir $ \dir -> initM >> test dir
149+
| (name,test) <-
150+
[ ("test",simpleMultiTest)
151+
, ("test2",simpleMultiTest2)
152+
, ("test3",simpleMultiTest3)
153+
, ("def-test",simpleMultiDefTest)
154+
]
155+
,
156+
let testName = multiTestName odir name
157+
]
158+
ignoreForWindows testName
159+
| testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270"
160+
| otherwise = id
136161

137162
multiTestName :: FilePath -> String -> String
138163
multiTestName dir name = "simple-" ++ dir ++ "-" ++ name
139164

140-
simpleMultiTest :: FilePath -> TestTree
141-
simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do
165+
simpleMultiTest :: FilePath -> Session ()
166+
simpleMultiTest = \dir -> do
142167
let aPath = dir </> "a/A.hs"
143168
bPath = dir </> "b/B.hs"
144169
adoc <- openDoc aPath "haskell"
@@ -153,8 +178,8 @@ simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtra
153178
expectNoMoreDiagnostics 0.5
154179

155180
-- Like simpleMultiTest but open the files in the other order
156-
simpleMultiTest2 :: FilePath -> TestTree
157-
simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExtraFiles variant $ \dir -> do
181+
simpleMultiTest2 :: FilePath -> Session ()
182+
simpleMultiTest2 = \dir -> do
158183
let aPath = dir </> "a/A.hs"
159184
bPath = dir </> "b/B.hs"
160185
bdoc <- openDoc bPath "haskell"
@@ -167,9 +192,8 @@ simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExt
167192
expectNoMoreDiagnostics 0.5
168193

169194
-- Now with 3 components
170-
simpleMultiTest3 :: FilePath -> TestTree
171-
simpleMultiTest3 variant =
172-
testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \dir -> do
195+
simpleMultiTest3 :: FilePath -> Session ()
196+
simpleMultiTest3 = \ dir -> do
173197
let aPath = dir </> "a/A.hs"
174198
bPath = dir </> "b/B.hs"
175199
cPath = dir </> "c/C.hs"
@@ -273,12 +297,31 @@ batchLoadRegressionTests =
273297
, testCase "s1-no-stale-outcomes-across-restart-paths" $
274298
runWithExtraFilesMultiComponent "multi" regressionNoStaleOutcomesOnRestart
275299
]
300+
++ [ testGroup "whole-project"
301+
[ testCase "m1-open-a-then-b-batch-pending-and-success" $
302+
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenAThenB
303+
, testCase "m2-open-b-then-a-batch-pending-and-success" $
304+
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenBThenA
305+
, testCase "m3-open-b-then-a-then-c-batch-pending-and-success" $
306+
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenBThenAThenC
307+
, testCase "f1-batch-pending-failure-does-not-isolate-broken-component" $
308+
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" regressionBatchFailureDoesNotIsolateBrokenComponent
309+
, testCase "f2-failed-file-keeps-failing-until-cradle-fix" $
310+
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" $ regressionFailedFileKeepsFailingUntilFix' False
311+
, testCase "r1-failed-file-recovers-after-cradle-fix" $
312+
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" regressionFailedFileRecoversAfterFix
313+
, testCase "s1-no-stale-outcomes-across-restart-paths" $
314+
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" $ regressionNoStaleOutcomesOnRestart' False
315+
]]
276316

277317
runWithExtraFilesMultiComponent :: String -> (FilePath -> Session a) -> IO a
278-
runWithExtraFilesMultiComponent dirName action = do
318+
runWithExtraFilesMultiComponent = runWithExtraFilesMultiComponent' PreferMultiComponentLoading
319+
320+
runWithExtraFilesMultiComponent' :: SessionLoadingPreferenceConfig -> String -> (FilePath -> Session a) -> IO a
321+
runWithExtraFilesMultiComponent' sesLoading dirName action = do
279322
let vfs = mkIdeTestFs [copyDir dirName]
280323
lspConfig :: Config
281-
lspConfig = def { sessionLoading = PreferMultiComponentLoading }
324+
lspConfig = def { sessionLoading = sesLoading }
282325
conf :: TestConfig ()
283326
conf = def
284327
{ testPluginDescriptor = dummyPlugin
@@ -321,6 +364,11 @@ assertTypeCheckFailure doc msg = do
321364
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
322365
liftIO $ assertBool msg (not ideResultSuccess)
323366

367+
setWholeProjectLoading :: Session ()
368+
setWholeProjectLoading = do
369+
setIgnoringConfigurationRequests False
370+
setHlsConfig def{sessionLoading = PreferMultiWholeProjectLoading}
371+
324372
regressionBatchFailureIsolatesBrokenFile :: FilePath -> Session ()
325373
regressionBatchFailureIsolatesBrokenFile dir = do
326374
writeBrokenMultiHieYaml dir
@@ -333,8 +381,24 @@ regressionBatchFailureIsolatesBrokenFile dir = do
333381
liftIO $ assertBool "A should typecheck when B cradle mapping is broken" (ideResultSuccess aRes)
334382
liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes)
335383

384+
-- | With whole-project loading a failed component blocks the whole session.
385+
regressionBatchFailureDoesNotIsolateBrokenComponent :: FilePath -> Session ()
386+
regressionBatchFailureDoesNotIsolateBrokenComponent dir = do
387+
writeBrokenMultiHieYaml dir
388+
let aPath = dir </> "a/A.hs"
389+
bPath = dir </> "b/B.hs"
390+
adoc <- openDoc aPath "haskell"
391+
bdoc <- openDoc bPath "haskell"
392+
_ <- waitForBuildQueue
393+
[aRes, bRes] <- waitForTypeChecksBatched [adoc, bdoc]
394+
liftIO $ assertBool "A should not typecheck when B cradle mapping is broken" (not $ ideResultSuccess aRes)
395+
liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes)
396+
336397
regressionFailedFileKeepsFailingUntilFix :: FilePath -> Session ()
337-
regressionFailedFileKeepsFailingUntilFix dir = do
398+
regressionFailedFileKeepsFailingUntilFix = regressionFailedFileKeepsFailingUntilFix' True
399+
400+
regressionFailedFileKeepsFailingUntilFix' :: Bool -> FilePath -> Session ()
401+
regressionFailedFileKeepsFailingUntilFix' isolated dir = do
338402
writeBrokenMultiHieYaml dir
339403
let aPath = dir </> "a/A.hs"
340404
bPath = dir </> "b/B.hs"
@@ -347,10 +411,11 @@ regressionFailedFileKeepsFailingUntilFix dir = do
347411
[TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
348412
assertTypeCheckFailure bdoc "B should keep failing until the cradle is fixed"
349413

350-
adoc <- openDoc aPath "haskell"
351-
cdoc <- openDoc cPath "haskell"
352-
assertTypeCheckSuccess adoc "A should still typecheck while B remains broken"
353-
assertTypeCheckSuccess cdoc "C should still typecheck while B remains broken"
414+
when isolated $ do
415+
adoc <- openDoc aPath "haskell"
416+
cdoc <- openDoc cPath "haskell"
417+
assertTypeCheckSuccess adoc "A should still typecheck while B remains broken"
418+
assertTypeCheckSuccess cdoc "C should still typecheck while B remains broken"
354419

355420
regressionFailedFileRecoversAfterFix :: FilePath -> Session ()
356421
regressionFailedFileRecoversAfterFix dir = do
@@ -371,7 +436,10 @@ regressionFailedFileRecoversAfterFix dir = do
371436
assertTypeCheckSuccess bdoc "B should recover after restoring the cradle"
372437

373438
regressionNoStaleOutcomesOnRestart :: FilePath -> Session ()
374-
regressionNoStaleOutcomesOnRestart dir = do
439+
regressionNoStaleOutcomesOnRestart = regressionNoStaleOutcomesOnRestart' True
440+
441+
regressionNoStaleOutcomesOnRestart' :: Bool -> FilePath -> Session ()
442+
regressionNoStaleOutcomesOnRestart' isolated dir = do
375443
let hiePath = dir </> "hie.yaml"
376444
aPath = dir </> "a/A.hs"
377445
bPath = dir </> "b/B.hs"
@@ -382,8 +450,9 @@ regressionNoStaleOutcomesOnRestart dir = do
382450
bdoc <- openDoc bPath "haskell"
383451
assertTypeCheckFailure bdoc "B should fail before cradle fix"
384452

385-
adoc <- openDoc aPath "haskell"
386-
assertTypeCheckSuccess adoc "A should remain healthy while B is broken"
453+
when isolated $ do
454+
adoc <- openDoc aPath "haskell"
455+
assertTypeCheckSuccess adoc "A should remain healthy while B is broken"
387456

388457
liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)
389458
notifyHieYamlChanged dir
@@ -397,9 +466,8 @@ regressionNoStaleOutcomesOnRestart dir = do
397466
assertTypeCheckSuccess bdoc "B should not keep stale failure after cradle restart"
398467

399468
-- Like simpleMultiTest but open the files in component 'a' in a separate session
400-
simpleMultiDefTest :: FilePath -> TestTree
401-
simpleMultiDefTest variant = ignoreForWindows $ testCase testName $
402-
runWithExtraFiles variant $ \dir -> do
469+
simpleMultiDefTest :: FilePath -> Session ()
470+
simpleMultiDefTest = \dir -> do
403471
let aPath = dir </> "a/A.hs"
404472
bPath = dir </> "b/B.hs"
405473
adoc <- openDoc aPath "haskell"
@@ -411,15 +479,11 @@ simpleMultiDefTest variant = ignoreForWindows $ testCase testName $
411479
let fooL = mkL (adoc ^. L.uri) 2 0 2 3
412480
checkDefs locs (pure [fooL])
413481
expectNoMoreDiagnostics 0.5
414-
where
415-
testName = multiTestName variant "def-test"
416-
ignoreForWindows
417-
| testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270"
418-
| otherwise = id
419482

420-
multiRexportTest :: TestTree
421-
multiRexportTest =
483+
multiRexportTest :: Session () -> TestTree
484+
multiRexportTest initM =
422485
testCase "multi-unit-reexport-test" $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do
486+
initM
423487
let cPath = dir </> "c/C.hs"
424488
cdoc <- openDoc cPath "haskell"
425489
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
@@ -429,10 +493,11 @@ multiRexportTest =
429493
checkDefs locs (pure [fooL])
430494
expectNoMoreDiagnostics 0.5
431495

432-
sessionDepsArePickedUp :: TestTree
433-
sessionDepsArePickedUp = testWithDummyPluginEmpty'
496+
sessionDepsArePickedUp :: Session () -> TestTree
497+
sessionDepsArePickedUp initM = testWithDummyPluginEmpty'
434498
"session-deps-are-picked-up"
435499
$ \dir -> do
500+
initM
436501
liftIO $
437502
atomicFileWriteStringUTF8
438503
(dir </> "hie.yaml")

0 commit comments

Comments
 (0)