Skip to content

Commit 80bf872

Browse files
fendorfendor
committed
Prefer explicit config value over callback for config initialisation
1 parent 9be3303 commit 80bf872

1 file changed

Lines changed: 132 additions & 110 deletions

File tree

‎ghcide-test/exe/CradleTests.hs‎

Lines changed: 132 additions & 110 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,6 @@ import Config (checkDefs, dummyPlugin,
1010
testWithDummyPluginEmpty')
1111
import Control.Applicative.Combinators
1212
import Control.Lens ((^.))
13-
import Control.Monad (when)
1413
import Control.Monad.IO.Class (liftIO)
1514
import qualified Data.Aeson as A
1615
import Data.Proxy (Proxy (..))
@@ -39,47 +38,58 @@ import System.FilePath
3938
import Test.Hls (TestConfig (..), def,
4039
runSessionWithTestConfig,
4140
setHlsConfig,
42-
waitForBuildQueue)
41+
waitForBuildQueue, expectFailBecause)
4342
import Test.Hls.FileSystem
4443
import Test.Hls.Util (EnvSpec (..), OS (..),
4544
ignoreInEnv)
4645
import Test.Tasty
4746
import Test.Tasty.HUnit
4847

48+
defComponentLoadingConf :: SessionLoadingPreferenceConfig
49+
defComponentLoadingConf = componentsLoading def
50+
51+
wholeProjectConf :: SessionLoadingPreferenceConfig
52+
wholeProjectConf = PreferMultiWholeProjectLoading
4953

5054
tests :: TestTree
5155
tests = testGroup "cradle"
52-
[testGroup "dependencies" $ bothLoadings1 sessionDepsArePickedUp
53-
,testGroup "ignore-fatal" $ bothLoadings1 ignoreFatalWarning
54-
,testGroup "loading" $ bothLoadings $ \initM -> [loadCradleOnlyonce initM, retryFailedCradle initM]
55-
,testGroup "regression.batch" batchLoadRegressionTests
56-
,testGroup "cross-cradle" [crossCradleBatchIsolationTest]
57-
,testGroup "multi" (multiTests "multi")
58-
,testGroup "multi-unit" (multiTests "multi-unit")
59-
,testGroup "sub-directory" $ bothLoadings1 simpleSubDirectoryTest
60-
,testGroup "multi-unit-rexport" $ bothLoadings1 multiRexportTest
56+
[ testGroup "whole project"
57+
[ testGroup "dependencies" [sessionDepsArePickedUp wholeProjectConf]
58+
, testGroup "ignore-fatal" [ignoreFatalWarning wholeProjectConf]
59+
, testGroup "loading" [loadCradleOnlyOnce wholeProjectConf, retryFailedCradle wholeProjectConf]
60+
, testGroup "regression.batch" (batchLoadRegressionTests wholeProjectConf)
61+
, testGroup "cross-cradle" [crossCradleBatchIsolationTest wholeProjectConf]
62+
, testGroup "multi" (multiTests wholeProjectConf "multi")
63+
, testGroup "multi-unit" (multiTests wholeProjectConf "multi-unit")
64+
, testGroup "sub-directory" [simpleSubDirectoryTest wholeProjectConf]
65+
, testGroup "multi-unit-rexport" [multiRexportTest wholeProjectConf]
6166
]
62-
63-
-- | Test both with the default `componentsLoading` and WholeProject.
64-
bothLoadings :: (Session () -> [TestTree]) -> [TestTree]
65-
bothLoadings m = [testGroup "default" (m (return ()))
66-
, testGroup "whole-project" (m setWholeProjectLoading)]
67-
bothLoadings1 :: (Session () -> TestTree) -> [TestTree]
68-
bothLoadings1 m = bothLoadings $ \ initM -> [m initM]
69-
70-
loadCradleOnlyonce :: Session () -> TestTree
71-
loadCradleOnlyonce initM = testGroup "load cradle only once"
72-
[ testWithDummyPluginEmpty' "implicit" implicit
73-
, testWithDummyPluginEmpty' "direct" direct
67+
, testGroup "default"
68+
[ testGroup "dependencies" [sessionDepsArePickedUp defComponentLoadingConf]
69+
, testGroup "ignore-fatal" [ignoreFatalWarning defComponentLoadingConf]
70+
, testGroup "loading" [loadCradleOnlyOnce defComponentLoadingConf, retryFailedCradle defComponentLoadingConf]
71+
, testGroup "regression.batch" (batchLoadRegressionTests defComponentLoadingConf)
72+
, testGroup "cross-cradle" [crossCradleBatchIsolationTest defComponentLoadingConf]
73+
, testGroup "multi" (multiTests defComponentLoadingConf "multi")
74+
, testGroup "multi-unit" (multiTests defComponentLoadingConf "multi-unit")
75+
, testGroup "sub-directory" [simpleSubDirectoryTest defComponentLoadingConf]
76+
, testGroup "multi-unit-rexport" [multiRexportTest defComponentLoadingConf]
7477
]
78+
]
79+
80+
loadCradleOnlyOnce :: SessionLoadingPreferenceConfig -> TestTree
81+
loadCradleOnlyOnce conf = testGroup "load cradle only once"
82+
[ testWithDummyPluginEmpty' "implicit" implicit
83+
, testWithDummyPluginEmpty' "direct" direct
84+
]
7585
where
7686
direct dir = do
7787
liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml")
7888
"cradle: {direct: {arguments: []}}"
7989
test dir
8090
implicit dir = test dir
8191
test _dir = do
82-
initM
92+
setComponentsLoadingPreference conf
8393
doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
8494
msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
8595
liftIO $ length msgs @?= 1
@@ -90,9 +100,9 @@ loadCradleOnlyonce initM = testGroup "load cradle only once"
90100
msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
91101
liftIO $ length msgs @?= 0
92102

93-
retryFailedCradle :: Session () -> TestTree
94-
retryFailedCradle initM = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
95-
initM
103+
retryFailedCradle :: SessionLoadingPreferenceConfig -> TestTree
104+
retryFailedCradle conf = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
105+
setComponentsLoadingPreference conf
96106
-- The false cradle always fails
97107
let hieContents = "cradle: {bios: {shell: \"false\"}}"
98108
hiePath = dir </> "hie.yaml"
@@ -120,18 +130,18 @@ cradleLoadedMessage = satisfy $ \case
120130
cradleLoadedMethod :: String
121131
cradleLoadedMethod = "ghcide/cradle/loaded"
122132

123-
ignoreFatalWarning :: Session () -> TestTree
124-
ignoreFatalWarning initM = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do
125-
initM
133+
ignoreFatalWarning :: SessionLoadingPreferenceConfig -> TestTree
134+
ignoreFatalWarning conf = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do
135+
setComponentsLoadingPreference conf
126136
let srcPath = dir </> "IgnoreFatal.hs"
127137
src <- liftIO $ readFileUtf8 srcPath
128138
_ <- createDoc srcPath "haskell" src
129139
expectNoMoreDiagnostics 5
130140

131-
simpleSubDirectoryTest :: Session () -> TestTree
132-
simpleSubDirectoryTest initM =
141+
simpleSubDirectoryTest :: SessionLoadingPreferenceConfig -> TestTree
142+
simpleSubDirectoryTest conf =
133143
testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do
134-
initM
144+
setComponentsLoadingPreference conf
135145
let mainPath = dir </> "a/src/Main.hs"
136146
mainSource <- liftIO $ readFileUtf8 mainPath
137147
_mdoc <- createDoc mainPath "haskell" mainSource
@@ -140,23 +150,22 @@ simpleSubDirectoryTest initM =
140150
]
141151
expectNoMoreDiagnostics 0.5
142152

143-
multiTests :: FilePath -> [TestTree]
144-
multiTests odir =
145-
[ testGroup "default" $ tests (return ())
146-
, testGroup "whole-project" $ tests setWholeProjectLoading
147-
]
153+
multiTests :: SessionLoadingPreferenceConfig -> FilePath -> [TestTree]
154+
multiTests conf odir =
155+
[ runOneTest testName test
156+
| (name,test) <-
157+
[ ("test",simpleMultiTest)
158+
, ("test2",simpleMultiTest2)
159+
, ("test3",simpleMultiTest3)
160+
, ("def-test",simpleMultiDefTest)
161+
]
162+
,
163+
let testName = multiTestName odir name
164+
]
148165
where
149-
tests initM =
150-
[ ignoreForWindows testName $ testCase testName $ runWithExtraFiles odir $ \dir -> initM >> test dir
151-
| (name,test) <-
152-
[ ("test",simpleMultiTest)
153-
, ("test2",simpleMultiTest2)
154-
, ("test3",simpleMultiTest3)
155-
, ("def-test",simpleMultiDefTest)
156-
]
157-
,
158-
let testName = multiTestName odir name
159-
]
166+
runOneTest testName act = ignoreForWindows testName $ testCase testName $ runWithExtraFiles odir $ \dir -> do
167+
setComponentsLoadingPreference conf
168+
act dir
160169
ignoreForWindows testName
161170
| testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270"
162171
| otherwise = id
@@ -315,52 +324,46 @@ waitForTypeChecksBatched docs = do
315324
A.Success res -> pure res
316325
A.Error parseErr -> liftIO (assertFailure $ "batched typecheck parse failed: " <> parseErr) >> pure []
317326

318-
batchLoadRegressionTests :: [TestTree]
319-
batchLoadRegressionTests =
327+
batchLoadRegressionTests :: SessionLoadingPreferenceConfig -> [TestTree]
328+
batchLoadRegressionTests conf =
320329
-- Note [Batch regression scheduling semantics]
321330
-- `didOpen` alone does not enqueue session-loader pending files.
322331
-- Pending entries come from GhcSession demand. For these tests, the `test`
323332
-- plugin uses `WaitForIdeRules` plus a pending-size barrier in session-loader
324333
-- to force all requested files into pending before load begins.
325334
[ testCase "m1-open-a-then-b-batch-pending-and-success" $
326-
runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenAThenB
335+
runWithExtraFilesMultiComponent conf "multi" runRegressionMultiOpenAThenB
327336
, testCase "m2-open-b-then-a-batch-pending-and-success" $
328-
runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenA
337+
runWithExtraFilesMultiComponent conf "multi" runRegressionMultiOpenBThenA
329338
, testCase "m3-open-b-then-a-then-c-batch-pending-and-success" $
330-
runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenAThenC
339+
runWithExtraFilesMultiComponent conf "multi" runRegressionMultiOpenBThenAThenC
331340
, testCase "m4-initial-multi-file-open-loads-cradle-once" $
332-
runWithExtraFilesMultiComponent "multi" runRegressionInitialOpenSingleBatchLoad
333-
, testCase "f1-batch-pending-failure-isolates-broken-file" $
334-
runWithExtraFilesMultiComponent "multi" regressionBatchFailureIsolatesBrokenFile
335-
, testCase "f2-failed-file-keeps-failing-until-cradle-fix" $
336-
runWithExtraFilesMultiComponent "multi" regressionFailedFileKeepsFailingUntilFix
341+
runWithExtraFilesMultiComponent conf "multi" runRegressionInitialOpenSingleBatchLoad
342+
, expectBrokenWithWholeProjectLoading conf $
343+
testCase "f1-batch-pending-failure-isolates-broken-file" $
344+
runWithExtraFilesMultiComponent conf "multi" regressionBatchFailureIsolatesBrokenFile
345+
, expectBrokenWithWholeProjectLoading conf $
346+
testCase "f2-failed-file-keeps-failing-until-cradle-fix" $
347+
runWithExtraFilesMultiComponent conf "multi" regressionFailedFileKeepsFailingUntilFix
348+
, testCase "f3-batch-pending-failure-does-not-isolate-broken-component" $
349+
runWithExtraFilesMultiComponent conf "multi" regressionBatchFailureDoesNotIsolateBrokenComponent
337350
, testCase "r1-failed-file-recovers-after-cradle-fix" $
338-
runWithExtraFilesMultiComponent "multi" regressionFailedFileRecoversAfterFix
339-
, testCase "s1-no-stale-outcomes-across-restart-paths" $
340-
runWithExtraFilesMultiComponent "multi" regressionNoStaleOutcomesOnRestart
351+
runWithExtraFilesMultiComponent conf "multi" regressionFailedFileRecoversAfterFix
352+
, expectBrokenWithWholeProjectLoading conf
353+
$ testCase "s1-no-stale-outcomes-across-restart-paths" $
354+
runWithExtraFilesMultiComponent conf "multi" regressionNoStaleOutcomesOnRestart
355+
, testCase "s2-no-stale-outcomes-across-restart-paths" $
356+
runWithExtraFilesMultiComponent conf "multi" regressionNoStaleOutcomesOnRestartNotHealthyInBetween
341357
]
342-
++ [ testGroup "whole-project"
343-
[ testCase "m1-open-a-then-b-batch-pending-and-success" $
344-
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenAThenB
345-
, testCase "m2-open-b-then-a-batch-pending-and-success" $
346-
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenBThenA
347-
, testCase "m3-open-b-then-a-then-c-batch-pending-and-success" $
348-
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" runRegressionMultiOpenBThenAThenC
349-
, testCase "f1-batch-pending-failure-does-not-isolate-broken-component" $
350-
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" regressionBatchFailureDoesNotIsolateBrokenComponent
351-
, testCase "f2-failed-file-keeps-failing-until-cradle-fix" $
352-
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" $ regressionFailedFileKeepsFailingUntilFix' False
353-
, testCase "r1-failed-file-recovers-after-cradle-fix" $
354-
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" regressionFailedFileRecoversAfterFix
355-
, testCase "s1-no-stale-outcomes-across-restart-paths" $
356-
runWithExtraFilesMultiComponent' PreferMultiWholeProjectLoading "multi" $ regressionNoStaleOutcomesOnRestart' False
357-
]]
358358

359-
runWithExtraFilesMultiComponent :: String -> (FilePath -> Session a) -> IO a
360-
runWithExtraFilesMultiComponent = runWithExtraFilesMultiComponent' PreferMultiComponentLoading
359+
expectBrokenWithWholeProjectLoading :: SessionLoadingPreferenceConfig -> TestTree -> TestTree
360+
expectBrokenWithWholeProjectLoading conf =
361+
if conf == wholeProjectConf
362+
then expectFailBecause "We can't load the whole project if the hie.yaml file is invalid"
363+
else id
361364

362-
runWithExtraFilesMultiComponent' :: SessionLoadingPreferenceConfig -> String -> (FilePath -> Session a) -> IO a
363-
runWithExtraFilesMultiComponent' sesLoading dirName action = do
365+
runWithExtraFilesMultiComponent :: SessionLoadingPreferenceConfig -> String -> (FilePath -> Session a) -> IO a
366+
runWithExtraFilesMultiComponent sesLoading dirName action = do
364367
let vfs = mkIdeTestFs [copyDir dirName]
365368
lspConfig :: Config
366369
lspConfig = def { componentsLoading = sesLoading }
@@ -406,10 +409,10 @@ assertTypeCheckFailure doc msg = do
406409
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
407410
liftIO $ assertBool msg (not ideResultSuccess)
408411

409-
setWholeProjectLoading :: Session ()
410-
setWholeProjectLoading = do
412+
setComponentsLoadingPreference :: SessionLoadingPreferenceConfig -> Session ()
413+
setComponentsLoadingPreference pref = do
411414
setIgnoringConfigurationRequests False
412-
setHlsConfig def{componentsLoading = PreferMultiWholeProjectLoading}
415+
setHlsConfig def{componentsLoading = pref}
413416

414417
regressionBatchFailureIsolatesBrokenFile :: FilePath -> Session ()
415418
regressionBatchFailureIsolatesBrokenFile dir = do
@@ -437,10 +440,7 @@ regressionBatchFailureDoesNotIsolateBrokenComponent dir = do
437440
liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes)
438441

439442
regressionFailedFileKeepsFailingUntilFix :: FilePath -> Session ()
440-
regressionFailedFileKeepsFailingUntilFix = regressionFailedFileKeepsFailingUntilFix' True
441-
442-
regressionFailedFileKeepsFailingUntilFix' :: Bool -> FilePath -> Session ()
443-
regressionFailedFileKeepsFailingUntilFix' isolated dir = do
443+
regressionFailedFileKeepsFailingUntilFix dir = do
444444
writeBrokenMultiHieYaml dir
445445
let aPath = dir </> "a/A.hs"
446446
bPath = dir </> "b/B.hs"
@@ -453,11 +453,10 @@ regressionFailedFileKeepsFailingUntilFix' isolated dir = do
453453
[TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
454454
assertTypeCheckFailure bdoc "B should keep failing until the cradle is fixed"
455455

456-
when isolated $ do
457-
adoc <- openDoc aPath "haskell"
458-
cdoc <- openDoc cPath "haskell"
459-
assertTypeCheckSuccess adoc "A should still typecheck while B remains broken"
460-
assertTypeCheckSuccess cdoc "C should still typecheck while B remains broken"
456+
adoc <- openDoc aPath "haskell"
457+
cdoc <- openDoc cPath "haskell"
458+
assertTypeCheckSuccess adoc "A should still typecheck while B remains broken"
459+
assertTypeCheckSuccess cdoc "C should still typecheck while B remains broken"
461460

462461
regressionFailedFileRecoversAfterFix :: FilePath -> Session ()
463462
regressionFailedFileRecoversAfterFix dir = do
@@ -478,10 +477,7 @@ regressionFailedFileRecoversAfterFix dir = do
478477
assertTypeCheckSuccess bdoc "B should recover after restoring the cradle"
479478

480479
regressionNoStaleOutcomesOnRestart :: FilePath -> Session ()
481-
regressionNoStaleOutcomesOnRestart = regressionNoStaleOutcomesOnRestart' True
482-
483-
regressionNoStaleOutcomesOnRestart' :: Bool -> FilePath -> Session ()
484-
regressionNoStaleOutcomesOnRestart' isolated dir = do
480+
regressionNoStaleOutcomesOnRestart dir = do
485481
let hiePath = dir </> "hie.yaml"
486482
aPath = dir </> "a/A.hs"
487483
bPath = dir </> "b/B.hs"
@@ -492,9 +488,35 @@ regressionNoStaleOutcomesOnRestart' isolated dir = do
492488
bdoc <- openDoc bPath "haskell"
493489
assertTypeCheckFailure bdoc "B should fail before cradle fix"
494490

495-
when isolated $ do
496-
adoc <- openDoc aPath "haskell"
497-
assertTypeCheckSuccess adoc "A should remain healthy while B is broken"
491+
adoc <- openDoc aPath "haskell"
492+
assertTypeCheckSuccess adoc "A should remain healthy while B is broken"
493+
494+
liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)
495+
notifyHieYamlChanged dir
496+
497+
cdoc <- openDoc cPath "haskell"
498+
assertTypeCheckSuccess cdoc "C should typecheck after cradle restart"
499+
500+
bSource <- liftIO $ readFileUtf8 bPath
501+
changeDoc bdoc
502+
[TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
503+
assertTypeCheckSuccess bdoc "B should not keep stale failure after cradle restart"
504+
505+
-- | Like 'regressionNoStaleOutcomesOnRestart', but we don't check that
506+
-- unrelated components can still be loaded.
507+
--
508+
-- When we load the whole project, we can't load intermediate components, since the hie.yaml =
509+
-- is broken.
510+
regressionNoStaleOutcomesOnRestartNotHealthyInBetween :: FilePath -> Session ()
511+
regressionNoStaleOutcomesOnRestartNotHealthyInBetween dir = do
512+
let hiePath = dir </> "hie.yaml"
513+
bPath = dir </> "b/B.hs"
514+
cPath = dir </> "c/C.hs"
515+
validHie <- liftIO $ readFileUtf8 hiePath
516+
writeBrokenMultiHieYaml dir
517+
518+
bdoc <- openDoc bPath "haskell"
519+
assertTypeCheckFailure bdoc "B should fail before cradle fix"
498520

499521
liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)
500522
notifyHieYamlChanged dir
@@ -512,10 +534,10 @@ regressionNoStaleOutcomesOnRestart' isolated dir = do
512534
-- cradle; once it is loaded, opening @a/A.hs@ (owned by the root cabal cradle)
513535
-- used to batch the standalone file into @cabal repl@, which cannot map it to
514536
-- any component and fails wholesale, poisoning the load of A.
515-
crossCradleBatchIsolationTest :: TestTree
516-
crossCradleBatchIsolationTest =
537+
crossCradleBatchIsolationTest :: SessionLoadingPreferenceConfig -> TestTree
538+
crossCradleBatchIsolationTest conf =
517539
testCase "direct-cradle-file-does-not-poison-cabal-load" $
518-
runWithExtraFilesMultiComponent "cross-cradle" $ \dir -> do
540+
runWithExtraFilesMultiComponent conf "cross-cradle" $ \dir -> do
519541
let standalonePath = dir </> "standalone/Standalone.hs"
520542
aPath = dir </> "a/A.hs"
521543
sdoc <- openDoc standalonePath "haskell"
@@ -539,10 +561,10 @@ simpleMultiDefTest = \dir -> do
539561
checkDefs locs (pure [fooL])
540562
expectNoMoreDiagnostics 0.5
541563

542-
multiRexportTest :: Session () -> TestTree
543-
multiRexportTest initM =
564+
multiRexportTest :: SessionLoadingPreferenceConfig -> TestTree
565+
multiRexportTest conf =
544566
testCase "multi-unit-reexport-test" $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do
545-
initM
567+
setComponentsLoadingPreference conf
546568
let cPath = dir </> "c/C.hs"
547569
cdoc <- openDoc cPath "haskell"
548570
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
@@ -552,11 +574,11 @@ multiRexportTest initM =
552574
checkDefs locs (pure [fooL])
553575
expectNoMoreDiagnostics 0.5
554576

555-
sessionDepsArePickedUp :: Session () -> TestTree
556-
sessionDepsArePickedUp initM = testWithDummyPluginEmpty'
577+
sessionDepsArePickedUp :: SessionLoadingPreferenceConfig -> TestTree
578+
sessionDepsArePickedUp conf = testWithDummyPluginEmpty'
557579
"session-deps-are-picked-up"
558580
$ \dir -> do
559-
initM
581+
setComponentsLoadingPreference conf
560582
liftIO $
561583
atomicFileWriteStringUTF8
562584
(dir </> "hie.yaml")

0 commit comments

Comments
 (0)