1111module Main (main ) where
1212
1313import Control.Applicative.Combinators
14- import Control.Exception (catch )
14+ import Control.Exception (bracket_ , catch )
1515import qualified Control.Lens as Lens
1616import Control.Monad
1717import Control.Monad.IO.Class (liftIO )
@@ -41,7 +41,7 @@ import Language.Haskell.LSP.Types.Capabilities
4141import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics , params , message )
4242import Language.Haskell.LSP.VFS (applyChange )
4343import Network.URI
44- import System.Environment.Blank (getEnv , setEnv )
44+ import System.Environment.Blank (unsetEnv , getEnv , setEnv )
4545import System.FilePath
4646import System.IO.Extra hiding (withTempDir )
4747import qualified System.IO.Extra
@@ -58,8 +58,10 @@ import Test.Tasty.HUnit
5858import Test.Tasty.QuickCheck
5959import System.Time.Extra
6060import Development.IDE.Plugin.CodeAction (typeSignatureCommandId , blockCommandId , matchRegExMultipleImports )
61- import Development.IDE.Plugin.Test (WaitForIdeRuleResult (.. ), TestRequest (WaitForIdeRule , BlockSeconds ,GetInterfaceFilesDir ))
61+ import Development.IDE.Plugin.Test (WaitForIdeRuleResult (.. ), TestRequest (BlockSeconds ,GetInterfaceFilesDir ))
6262import Control.Monad.Extra (whenJust )
63+ import qualified Language.Haskell.LSP.Types.Lens as L
64+ import Control.Lens ((^.) )
6365
6466main :: IO ()
6567main = do
@@ -630,11 +632,6 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r
630632 -- similar to run except it disables kick
631633 runTestNoKick s = withTempDir $ \ dir -> runInDir' dir " ." " ." " --test-no-kick"
632634
633- waitForAction key TextDocumentIdentifier {_uri} = do
634- waitId <- sendRequest (CustomClientMethod " test" WaitForIdeRule key _uri)
635- ResponseMessage {_result} <- skipManyTill anyMessage $ responseForId waitId
636- return _result
637-
638635 typeCheck doc = do
639636 Right WaitForIdeRuleResult {.. } <- waitForAction " TypeCheck"
640637 liftIO $ assertBool " The file should typecheck"
@@ -3442,7 +3439,7 @@ cradleTests :: TestTree
34423439cradleTests = testGroup " cradle"
34433440 [testGroup " dependencies"
34443441 ,testGroup " ignore-fatal"
3445- ,testGroup " loading"
3442+ ,testGroup " loading" , retryFailedCradle ]
34463443 ,testGroup " multi"
34473444 ,testGroup " sub-directory"
34483445 ]
@@ -3469,6 +3466,43 @@ loadCradleOnlyonce = testGroup "load cradle only once"
34693466 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @ PublishDiagnosticsNotification ))
34703467 liftIO $ length msgs @?= 0
34713468
3469+ retryFailedCradle :: TestTree
3470+ retryFailedCradle = testSession' " retry failed" $ \ dir -> do
3471+ -- The false cradle always fails
3472+ let hieContents = " cradle: {bios: {shell: \" false\" }}"
3473+ hiePath = dir </> " hie.yaml"
3474+ liftIO $ writeFile hiePath hieContents
3475+ hieDoc <- createDoc hiePath " yaml" $ T. pack hieContents
3476+ let aPath = dir </> " A.hs"
3477+ doc <- createDoc aPath " haskell" " main = return ()"
3478+ Right WaitForIdeRuleResult {.. } <- waitForAction " TypeCheck"
3479+ liftIO $ " Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess
3480+
3481+ -- Fix the cradle and typecheck again
3482+ let validCradle = " cradle: {bios: {shell: \" echo A.hs\" }}"
3483+ liftIO $ writeFileUTF8 hiePath $ T. unpack validCradle
3484+ changeDoc
3485+ hieDoc
3486+ [ TextDocumentContentChangeEvent
3487+ { _range = Nothing ,
3488+ _rangeLength = Nothing ,
3489+ _text = validCradle
3490+ }
3491+ ]
3492+
3493+ -- Force a session restart by making an edit, just to dirty the typecheck node
3494+ changeDoc
3495+ doc
3496+ [ TextDocumentContentChangeEvent
3497+ { _range = Just Range {_start = Position 0 0 , _end = Position 0 0 },
3498+ _rangeLength = Nothing ,
3499+ _text = " \n "
3500+ }
3501+ ]
3502+
3503+ Right WaitForIdeRuleResult {.. } <- waitForAction " TypeCheck"
3504+ liftIO $ " No joy after fixing the cradle" `assertBool` ideResultSuccess
3505+
34723506
34733507dependentFileTest :: TestTree
34743508dependentFileTest = testGroup " addDependentFile"
@@ -3533,17 +3567,19 @@ simpleSubDirectoryTest =
35333567 expectNoMoreDiagnostics 0.5
35343568
35353569simpleMultiTest :: TestTree
3536- simpleMultiTest = testCase " simple-multi-test" $ runWithExtraFiles " multi" $ \ dir -> do
3570+ simpleMultiTest = testCase " simple-multi-test" $ withLongTimeout $ runWithExtraFiles " multi" $ \ dir -> do
35373571 let aPath = dir </> " a/A.hs"
35383572 bPath = dir </> " b/B.hs"
35393573 aSource <- liftIO $ readFileUtf8 aPath
3540- (TextDocumentIdentifier adoc) <- createDoc aPath " haskell"
3541- expectNoMoreDiagnostics 0.5
3574+ adoc <- createDoc aPath " haskell"
3575+ Right WaitForIdeRuleResult {.. } <- waitForAction " TypeCheck"
3576+ liftIO $ assertBool " A should typecheck"
35423577 bSource <- liftIO $ readFileUtf8 bPath
35433578 bdoc <- createDoc bPath " haskell"
3544- expectNoMoreDiagnostics 0.5
3579+ Right WaitForIdeRuleResult {.. } <- waitForAction " TypeCheck"
3580+ liftIO $ assertBool " B should typecheck"
35453581 locs <- getDefinitions bdoc (Position 2 7 )
3546- let fooL = mkL adoc 2 0 2 3
3582+ let fooL = mkL ( adoc ^. L. uri) 2 0 2 3
35473583 checkDefs locs (pure [fooL])
35483584 expectNoMoreDiagnostics 0.5
35493585
@@ -3909,6 +3945,9 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir)
39093945runInDir :: FilePath -> Session a -> IO a
39103946runInDir dir = runInDir' dir " ." " ." []
39113947
3948+ withLongTimeout :: IO a -> IO a
3949+ withLongTimeout = bracket_ (setEnv " LSP_TIMEOUT" " 120" True " LSP_TIMEOUT"
3950+
39123951-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.
39133952runInDir' :: FilePath -> FilePath -> FilePath -> [String -> Session a -> IO a
39143953runInDir' dir startExeIn startSessionIn extraOptions s = do
@@ -3929,19 +3968,19 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do
39293968 setEnv " HOME" " /homeless-shelter" False
39303969 let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True
39313970 logColor <- fromMaybe True <$> checkEnv " LSP_TEST_LOG_COLOR"
3971+ timeoutOverride <- fmap read <$> getEnv " LSP_TIMEOUT"
3972+ let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride}
3973+ -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging
3974+ -- { logStdErr = True }
3975+ -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages
3976+ -- { logMessages = True }
39323977 runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s
39333978 where
39343979 checkEnv :: String -> IO Maybe Bool
39353980 checkEnv s = fmap convertVal <$> getEnv s
39363981 convertVal " 0" = False
39373982 convertVal _ = True
39383983
3939- conf = defaultConfig
3940- -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging
3941- -- { logStdErr = True }
3942- -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages
3943- -- { logMessages = True }
3944-
39453984openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
39463985openTestDataDoc path = do
39473986 source <- liftIO $ readFileUtf8 $ " test/data" </> path
0 commit comments