diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 777cc3954b..ef09e45726 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -329,7 +329,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do let res = (map (renderCradleError ncfp) err, Nothing) modifyVar_ fileToFlags $ \var -> do pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var - return (res,[]) + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies @@ -360,7 +360,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do getOptions file = do hieYaml <- cradleLoc file sessionOpts (hieYaml, file) `catch` \e -> - return (([renderPackageSetupException file e], Nothing),[]) + return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index d7bf6b2618..1416363b1e 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -11,7 +11,7 @@ module Main (main) where import Control.Applicative.Combinators -import Control.Exception (catch) +import Control.Exception (bracket_, catch) import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (liftIO) @@ -41,7 +41,7 @@ import Language.Haskell.LSP.Types.Capabilities import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message) import Language.Haskell.LSP.VFS (applyChange) import Network.URI -import System.Environment.Blank (getEnv, setEnv) +import System.Environment.Blank (unsetEnv, getEnv, setEnv) import System.FilePath import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra @@ -58,8 +58,10 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck import System.Time.Extra import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports) -import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(WaitForIdeRule, BlockSeconds,GetInterfaceFilesDir)) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(BlockSeconds,GetInterfaceFilesDir)) import Control.Monad.Extra (whenJust) +import qualified Language.Haskell.LSP.Types.Lens as L +import Control.Lens ((^.)) main :: IO () main = do @@ -630,11 +632,6 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r -- similar to run except it disables kick runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s - waitForAction key TextDocumentIdentifier{_uri} = do - waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId - return _result - typeCheck doc = do Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool "The file should typecheck" ideResultSuccess @@ -3388,7 +3385,7 @@ cradleTests :: TestTree cradleTests = testGroup "cradle" [testGroup "dependencies" [sessionDepsArePickedUp] ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] ,testGroup "multi" [simpleMultiTest, simpleMultiTest2] ,testGroup "sub-directory" [simpleSubDirectoryTest] ] @@ -3415,6 +3412,43 @@ loadCradleOnlyonce = testGroup "load cradle only once" msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) liftIO $ length msgs @?= 0 +retryFailedCradle :: TestTree +retryFailedCradle = testSession' "retry failed" $ \dir -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = dir "hie.yaml" + liftIO $ writeFile hiePath hieContents + hieDoc <- createDoc hiePath "yaml" $ T.pack hieContents + let aPath = dir "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + Right 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 $ writeFileUTF8 hiePath $ T.unpack validCradle + changeDoc + hieDoc + [ TextDocumentContentChangeEvent + { _range = Nothing, + _rangeLength = Nothing, + _text = validCradle + } + ] + + -- Force a session restart by making an edit, just to dirty the typecheck node + changeDoc + doc + [ TextDocumentContentChangeEvent + { _range = Just Range {_start = Position 0 0, _end = Position 0 0}, + _rangeLength = Nothing, + _text = "\n" + } + ] + + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + dependentFileTest :: TestTree dependentFileTest = testGroup "addDependentFile" @@ -3479,17 +3513,19 @@ simpleSubDirectoryTest = expectNoMoreDiagnostics 0.5 simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ runWithExtraFiles "multi" $ \dir -> do +simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" aSource <- liftIO $ readFileUtf8 aPath - (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource - expectNoMoreDiagnostics 0.5 + adoc <- createDoc aPath "haskell" aSource + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess bSource <- liftIO $ readFileUtf8 bPath bdoc <- createDoc bPath "haskell" bSource - expectNoMoreDiagnostics 0.5 + Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + liftIO $ assertBool "B should typecheck" ideResultSuccess locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL adoc 2 0 2 3 + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 checkDefs locs (pure [fooL]) expectNoMoreDiagnostics 0.5 @@ -3855,6 +3891,9 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a runInDir dir = runInDir' dir "." "." [] +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") + -- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a runInDir' dir startExeIn startSessionIn extraOptions s = do @@ -3875,6 +3914,12 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do setEnv "HOME" "/homeless-shelter" False let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" + timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" + let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} + -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging + -- { logStdErr = True } + -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages + -- { logMessages = True } runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s where checkEnv :: String -> IO (Maybe Bool) @@ -3882,12 +3927,6 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do convertVal "0" = False convertVal _ = True - conf = defaultConfig - -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging - -- { logStdErr = True } - -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages - -- { logMessages = True } - openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do source <- liftIO $ readFileUtf8 $ "test/data" path diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 1a10a30690..bcecdc3dbb 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -15,7 +15,9 @@ module Development.IDE.Test , checkDiagnosticsForDoc , canonicalizeUri , standardizeQuotes - ,flushMessages) where + , flushMessages + , waitForAction + ) where import Control.Applicative.Combinators import Control.Lens hiding (List) @@ -32,6 +34,7 @@ import System.Time.Extra import Test.Tasty.HUnit import System.Directory (canonicalizePath) import Data.Maybe (fromJust) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(WaitForIdeRule)) -- | (0-based line number, 0-based column number) @@ -180,3 +183,9 @@ standardizeQuotes msg = let repl '`' = '\'' repl c = c in T.map repl msg + +waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction key TextDocumentIdentifier{_uri} = do + waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri) + ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId + return _result