{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module CradleTests (tests) where
import Config (checkDefs, dummyPlugin,
lspTestCaps, mkIdeTestFs, mkL,
runWithExtraFiles,
testWithDummyPluginEmpty')
import Control.Applicative.Combinators
import Control.Lens ((^.))
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as A
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import Development.IDE.GHC.Util
import Development.IDE.Plugin.Test (TestRequest (..),
WaitForIdeRuleResult (..))
import Development.IDE.Test (expectDiagnostics,
expectDiagnosticsWithTags,
expectNoMoreDiagnostics,
isReferenceReady,
waitForAction)
import Development.IDE.Types.Location
import GHC.TypeLits (symbolVal)
import Ide.Types (Config (..),
SessionLoadingPreferenceConfig (..))
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.Test
import System.FilePath
import Test.Hls (TestConfig (..), def,
runSessionWithTestConfig,
waitForBuildQueue)
import Test.Hls.FileSystem
import Test.Hls.Util (EnvSpec (..), OS (..),
ignoreInEnv)
import Test.Tasty
import Test.Tasty.HUnit
tests :: TestTree
tests = testGroup "cradle"
[testGroup "dependencies" [sessionDepsArePickedUp]
,testGroup "ignore-fatal" [ignoreFatalWarning]
,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
,testGroup "regression.batch" batchLoadRegressionTests
,testGroup "multi" (multiTests "multi")
,testGroup "multi-unit" (multiTests "multi-unit")
,testGroup "sub-directory" [simpleSubDirectoryTest]
,testGroup "multi-unit-rexport" [multiRexportTest]
]
loadCradleOnlyonce :: TestTree
loadCradleOnlyonce = testGroup "load cradle only once"
[ testWithDummyPluginEmpty' "implicit" implicit
, testWithDummyPluginEmpty' "direct" direct
]
where
direct dir = do
liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml")
"cradle: {direct: {arguments: []}}"
test dir
implicit dir = test dir
test _dir = do
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
changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ "module B where\nimport Data.Maybe"]
msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
liftIO $ length msgs @?= 0
_ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))
liftIO $ length msgs @?= 0
retryFailedCradle :: TestTree
retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
-- The false cradle always fails
let hieContents = "cradle: {bios: {shell: \"false\"}}"
hiePath = dir </> "hie.yaml"
liftIO $ atomicFileWriteString hiePath hieContents
let aPath = dir </> "A.hs"
doc <- createDoc aPath "haskell" "main = return ()"
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess
-- Fix the cradle and typecheck again
let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"
liftIO $ atomicFileWriteStringUTF8 hiePath $ T.unpack validCradle
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
[FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess
cradleLoadedMessage :: Session FromServerMessage
cradleLoadedMessage = satisfy $ \case
FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod
_ -> False
cradleLoadedMethod :: String
cradleLoadedMethod = "ghcide/cradle/loaded"
ignoreFatalWarning :: TestTree
ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do
let srcPath = dir </> "IgnoreFatal.hs"
src <- liftIO $ readFileUtf8 srcPath
_ <- createDoc srcPath "haskell" src
expectNoMoreDiagnostics 5
simpleSubDirectoryTest :: TestTree
simpleSubDirectoryTest =
testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do
let mainPath = dir </> "a/src/Main.hs"
mainSource <- liftIO $ readFileUtf8 mainPath
_mdoc <- createDoc mainPath "haskell" mainSource
expectDiagnosticsWithTags
[("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Just "GHC-38417", Nothing)]) -- So that we know P has been loaded
]
expectNoMoreDiagnostics 0.5
multiTests :: FilePath -> [TestTree]
multiTests dir =
[ simpleMultiTest dir
, simpleMultiTest2 dir
, simpleMultiTest3 dir
, simpleMultiDefTest dir
]
multiTestName :: FilePath -> String -> String
multiTestName dir name = "simple-" ++ dir ++ "-" ++ name
simpleMultiTest :: FilePath -> TestTree
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"
bdoc <- openDoc bPath "haskell"
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc
liftIO $ assertBool "A should typecheck" ideResultSuccess
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc
liftIO $ assertBool "B should typecheck" ideResultSuccess
locs <- getDefinitions bdoc (Position 2 7)
let fooL = mkL (adoc ^. L.uri) 2 0 2 3
checkDefs locs (pure [fooL])
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
let aPath = dir </> "a/A.hs"
bPath = dir </> "b/B.hs"
bdoc <- openDoc bPath "haskell"
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc
TextDocumentIdentifier auri <- openDoc aPath "haskell"
skipManyTill anyMessage $ isReferenceReady aPath
locs <- getDefinitions bdoc (Position 2 7)
let fooL = mkL auri 2 0 2 3
checkDefs locs (pure [fooL])
expectNoMoreDiagnostics 0.5
-- Now with 3 components
simpleMultiTest3 :: FilePath -> TestTree
simpleMultiTest3 variant =
testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \dir -> do
let aPath = dir </> "a/A.hs"
bPath = dir </> "b/B.hs"
cPath = dir </> "c/C.hs"
bdoc <- openDoc bPath "haskell"
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc
TextDocumentIdentifier auri <- openDoc aPath "haskell"
skipManyTill anyMessage $ isReferenceReady aPath
cdoc <- openDoc cPath "haskell"
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
locs <- getDefinitions cdoc (Position 2 7)
let fooL = mkL auri 2 0 2 3
checkDefs locs (pure [fooL])
expectNoMoreDiagnostics 0.5
runRegressionMultiOpenAThenB :: FilePath -> Session ()
runRegressionMultiOpenAThenB dir = do
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 typecheck" (ideResultSuccess aRes)
liftIO $ assertBool "B should typecheck" (ideResultSuccess bRes)
locs <- getDefinitions bdoc (Position 2 7)
let fooL = mkL (adoc ^. L.uri) 2 0 2 3
checkDefs locs (pure [fooL])
expectNoMoreDiagnostics 0.5
runRegressionMultiOpenBThenA :: FilePath -> Session ()
runRegressionMultiOpenBThenA dir = do
let aPath = dir </> "a/A.hs"
bPath = dir </> "b/B.hs"
bdoc <- openDoc bPath "haskell"
adoc <- openDoc aPath "haskell"
_ <- waitForBuildQueue
[bRes, aRes] <- waitForTypeChecksBatched [bdoc, adoc]
liftIO $ assertBool "B should typecheck" (ideResultSuccess bRes)
liftIO $ assertBool "A should typecheck" (ideResultSuccess aRes)
locs <- getDefinitions bdoc (Position 2 7)
let TextDocumentIdentifier auri = adoc
let fooL = mkL auri 2 0 2 3
checkDefs locs (pure [fooL])
expectNoMoreDiagnostics 0.5
runRegressionMultiOpenBThenAThenC :: FilePath -> Session ()
runRegressionMultiOpenBThenAThenC dir = do
let aPath = dir </> "a/A.hs"
bPath = dir </> "b/B.hs"
cPath = dir </> "c/C.hs"
bdoc <- openDoc bPath "haskell"
adoc <- openDoc aPath "haskell"
cdoc <- openDoc cPath "haskell"
_ <- waitForBuildQueue
[bRes, aRes, cRes] <- waitForTypeChecksBatched [bdoc, adoc, cdoc]
liftIO $ assertBool "B should typecheck" (ideResultSuccess bRes)
liftIO $ assertBool "A should typecheck" (ideResultSuccess aRes)
liftIO $ assertBool "C should typecheck" (ideResultSuccess cRes)
locs <- getDefinitions cdoc (Position 2 7)
let TextDocumentIdentifier auri = adoc
let fooL = mkL auri 2 0 2 3
checkDefs locs (pure [fooL])
expectNoMoreDiagnostics 0.5
sendTestRequest :: TestRequest -> Session A.Value
sendTestRequest req = do
let method = SMethod_CustomMethod (Proxy @"test")
reqId <- sendRequest method (A.toJSON req)
TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId method reqId
case _result of
Left err -> liftIO (assertFailure $ "test plugin request failed: " <> show err) >> pure A.Null
Right val -> pure val
waitForTypeChecksBatched :: [TextDocumentIdentifier] -> Session [WaitForIdeRuleResult]
waitForTypeChecksBatched docs = do
let uris = map (\TextDocumentIdentifier{_uri} -> _uri) docs
val <- sendTestRequest (WaitForIdeRules "TypeCheck" uris)
case A.fromJSON val of
A.Success res -> pure res
A.Error parseErr -> liftIO (assertFailure $ "batched typecheck parse failed: " <> parseErr) >> pure []
batchLoadRegressionTests :: [TestTree]
batchLoadRegressionTests =
-- Note [Batch regression scheduling semantics]
-- `didOpen` alone does not enqueue session-loader pending files.
-- Pending entries come from GhcSession demand. For these tests, the `test`
-- plugin uses `WaitForIdeRules` plus a pending-size barrier in session-loader
-- to force all requested files into pending before load begins.
[ testCase "m1-open-a-then-b-batch-pending-and-success" $
runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenAThenB
, testCase "m2-open-b-then-a-batch-pending-and-success" $
runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenA
, testCase "m3-open-b-then-a-then-c-batch-pending-and-success" $
runWithExtraFilesMultiComponent "multi" runRegressionMultiOpenBThenAThenC
, testCase "f1-batch-pending-failure-isolates-broken-file" $
runWithExtraFilesMultiComponent "multi" regressionBatchFailureIsolatesBrokenFile
, testCase "f2-failed-file-keeps-failing-until-cradle-fix" $
runWithExtraFilesMultiComponent "multi" regressionFailedFileKeepsFailingUntilFix
, testCase "r1-failed-file-recovers-after-cradle-fix" $
runWithExtraFilesMultiComponent "multi" regressionFailedFileRecoversAfterFix
, testCase "s1-no-stale-outcomes-across-restart-paths" $
runWithExtraFilesMultiComponent "multi" regressionNoStaleOutcomesOnRestart
]
runWithExtraFilesMultiComponent :: String -> (FilePath -> Session a) -> IO a
runWithExtraFilesMultiComponent dirName action = do
let vfs = mkIdeTestFs [copyDir dirName]
lspConfig :: Config
lspConfig = def { sessionLoading = PreferMultiComponentLoading }
conf :: TestConfig ()
conf = def
{ testPluginDescriptor = dummyPlugin
, testDirLocation = Right vfs
, testConfigCaps = lspTestCaps
, testShiftRoot = True
, testDisableKick = True
, testLspConfig = lspConfig
}
runSessionWithTestConfig conf action
brokenMultiHieYaml :: T.Text
brokenMultiHieYaml = T.unlines
[ "cradle:"
, " cabal:"
, " - path: \"./a\""
, " component: \"lib:a\""
, " - path: \"./b\""
, " component: \"lib:does-not-exist\""
, " - path: \"./c\""
, " component: \"lib:c\""
]
writeBrokenMultiHieYaml :: FilePath -> Session ()
writeBrokenMultiHieYaml dir =
liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml") (T.unpack brokenMultiHieYaml)
notifyHieYamlChanged :: FilePath -> Session ()
notifyHieYamlChanged dir =
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
[FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed]
assertTypeCheckSuccess :: TextDocumentIdentifier -> String -> Session ()
assertTypeCheckSuccess doc msg = do
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
liftIO $ assertBool msg ideResultSuccess
assertTypeCheckFailure :: TextDocumentIdentifier -> String -> Session ()
assertTypeCheckFailure doc msg = do
WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
liftIO $ assertBool msg (not ideResultSuccess)
regressionBatchFailureIsolatesBrokenFile :: FilePath -> Session ()
regressionBatchFailureIsolatesBrokenFile 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 typecheck when B cradle mapping is broken" (ideResultSuccess aRes)
liftIO $ assertBool "B should fail with a broken cradle mapping" (not $ ideResultSuccess bRes)
regressionFailedFileKeepsFailingUntilFix :: FilePath -> Session ()
regressionFailedFileKeepsFailingUntilFix dir = do
writeBrokenMultiHieYaml dir
let aPath = dir </> "a/A.hs"
bPath = dir </> "b/B.hs"
cPath = dir </> "c/C.hs"
bdoc <- openDoc bPath "haskell"
assertTypeCheckFailure bdoc "B should fail with broken cradle mapping"
bSource <- liftIO $ readFileUtf8 bPath
changeDoc bdoc
[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"
regressionFailedFileRecoversAfterFix :: FilePath -> Session ()
regressionFailedFileRecoversAfterFix dir = do
let hiePath = dir </> "hie.yaml"
bPath = dir </> "b/B.hs"
validHie <- liftIO $ readFileUtf8 hiePath
writeBrokenMultiHieYaml dir
bdoc <- openDoc bPath "haskell"
assertTypeCheckFailure bdoc "B should fail before fixing the cradle"
liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)
notifyHieYamlChanged dir
bSource <- liftIO $ readFileUtf8 bPath
changeDoc bdoc
[TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
assertTypeCheckSuccess bdoc "B should recover after restoring the cradle"
regressionNoStaleOutcomesOnRestart :: FilePath -> Session ()
regressionNoStaleOutcomesOnRestart dir = do
let hiePath = dir </> "hie.yaml"
aPath = dir </> "a/A.hs"
bPath = dir </> "b/B.hs"
cPath = dir </> "c/C.hs"
validHie <- liftIO $ readFileUtf8 hiePath
writeBrokenMultiHieYaml dir
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"
liftIO $ atomicFileWriteStringUTF8 hiePath (T.unpack validHie)
notifyHieYamlChanged dir
cdoc <- openDoc cPath "haskell"
assertTypeCheckSuccess cdoc "C should typecheck after cradle restart"
bSource <- liftIO $ readFileUtf8 bPath
changeDoc bdoc
[TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ bSource <> "\n"]
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
let aPath = dir </> "a/A.hs"
bPath = dir </> "b/B.hs"
adoc <- openDoc aPath "haskell"
skipManyTill anyMessage $ isReferenceReady aPath
closeDoc adoc
bSource <- liftIO $ readFileUtf8 bPath
bdoc <- createDoc bPath "haskell" bSource
locs <- getDefinitions bdoc (Position 2 7)
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 =
testCase "multi-unit-reexport-test" $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do
let cPath = dir </> "c/C.hs"
cdoc <- openDoc cPath "haskell"
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
locs <- getDefinitions cdoc (Position 3 7)
let aPath = dir </> "a/A.hs"
let fooL = mkL (filePathToUri aPath) 2 0 2 3
checkDefs locs (pure [fooL])
expectNoMoreDiagnostics 0.5
sessionDepsArePickedUp :: TestTree
sessionDepsArePickedUp = testWithDummyPluginEmpty'
"session-deps-are-picked-up"
$ \dir -> do
liftIO $
atomicFileWriteStringUTF8
(dir </> "hie.yaml")
"cradle: {direct: {arguments: []}}"
-- Open without OverloadedStrings and expect an error.
doc <- createDoc "Foo.hs" "haskell" fooContent
expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type", Just "GHC-83865")])]
-- Update hie.yaml to enable OverloadedStrings.
liftIO $
atomicFileWriteStringUTF8
(dir </> "hie.yaml")
"cradle: {direct: {arguments: [-XOverloadedStrings]}}"
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
[FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]
-- Send change event.
let change =
TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial
{ _range = Range (Position 4 0) (Position 4 0)
, _rangeLength = Nothing
, _text = "\n"
}
changeDoc doc [change]
-- Now no errors.
expectDiagnostics [("Foo.hs", [])]
where
fooContent =
T.unlines
[ "module Foo where",
"import Data.Text",
"foo :: Text",
"foo = \"hello\""
]