Merge pull request #762 from pepeiborra/retry-cradle

Retry a failed cradle if the cradle descriptor changes

Author: jneira

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

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,19 +3914,19 @@ 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)
     checkEnv s = fmap convertVal <$> getEnv s
     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

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