Make iface-error-test-1 less flaky (haskell#2882)

* remove duplicate log message

* Fix expectNoMoreDiagnostics

* redundant import

* dead code

* unnecessary do section

* redundant log message

* waitForProgressDone to improve consistency

* redundant import

Author: pepeiborra

ghcide/src/Development/IDE/Core/Debouncer.hs

@@ -50,9 +50,8 @@ asyncRegisterEvent d delay k fire = mask_ $ do
         sleep delay
         fire
         atomically $ STM.delete k d
-    do
-        prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d
-        traverse_ cancel prev
+    prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d
+    traverse_ cancel prev
 
 -- | Debouncer used in the DAML CLI compiler that emits events immediately.
 noopDebouncer :: Debouncer k

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -28,7 +28,6 @@ import           Control.Exception
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import qualified Data.ByteString                              as BS
-import           Data.Either.Extra
 import qualified Data.Rope.UTF16                              as Rope
 import qualified Data.Text                                    as T
 import           Data.Time
@@ -192,12 +191,6 @@ getFileContentsImpl file = do
         pure $ Rope.toText . _text <$> mbVirtual
     pure ([], Just (time, res))
 
-ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
-ideTryIOException fp act =
-  mapLeft
-      (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
-      <$> try act
-
 -- | Returns the modification time and the contents.
 --   For VFS paths, the modification time is the current time.
 getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)

ghcide/src/Development/IDE/Core/OfInterest.hs

@@ -107,10 +107,10 @@ addFileOfInterest state f v = do
     (prev, files) <- modifyVar var $ \dict -> do
         let (prev, new) = HashMap.alterF (, Just v) f dict
         pure (new, (prev, new))
-    when (prev /= Just v) $
+    when (prev /= Just v) $ do
         join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
-    logDebug (ideLogger state) $
-        "Set files of interest to: " <> T.pack (show files)
+        logDebug (ideLogger state) $
+            "Set files of interest to: " <> T.pack (show files)
 
 deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
 deleteFileOfInterest state f = do

ghcide/src/Development/IDE/Core/Shake.hs

@@ -696,17 +696,6 @@ shakeRestart recorder IdeState{..} vfs reason acts =
               queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
 
               log Debug $ LogBuildSessionRestart reason queue backlog stopTime res
-
-              let profile = case res of
-                      Just fp -> ", profile saved at " <> fp
-                      _       -> ""
-              -- TODO: should replace with logging using a logger that sends lsp message
-              let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg
-                  reason' = "due to " ++ reason
-                  queueMsg = " with queue " ++ show (map actionName queue)
-                  keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " "
-                  abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")"
-              notifyTestingLogMessage shakeExtras msg
         )
         -- It is crucial to be masked here, otherwise we can get killed
         -- between spawning the new thread and updating shakeSession.
@@ -719,13 +708,6 @@ shakeRestart recorder IdeState{..} vfs reason acts =
             sleep seconds
             logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds)
 
-notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()
-notifyTestingLogMessage extras msg = do
-    (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras
-    let notif = LSP.LogMessageParams LSP.MtLog msg
-    when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif
-
-
 -- | Enqueue an action in the existing 'ShakeSession'.
 --   Returns a computation to block until the action is run, propagating exceptions.
 --   Assumes a 'ShakeSession' is available.
@@ -797,17 +779,12 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
           let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)
           res <- try @SomeException $
             restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs
-          let res' = case res of
-                      Left e  -> "exception: " <> displayException e
-                      Right _ -> "completed"
-          let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"
           return $ do
               let exception =
                     case res of
                       Left e -> Just e
                       _      -> Nothing
               logWith recorder Debug $ LogBuildSessionFinish exception
-              notifyTestingLogMessage extras msg
 
     -- Do the work in a background thread
     workThread <- asyncWithUnmask workRun

ghcide/test/exe/Main.hs

@@ -22,7 +22,7 @@ import           Control.Exception                        (bracket_, catch,
 import qualified Control.Lens                             as Lens
 import           Control.Monad
 import           Control.Monad.IO.Class                   (MonadIO, liftIO)
-import           Data.Aeson                               (fromJSON, toJSON)
+import           Data.Aeson                               (toJSON)
 import qualified Data.Aeson                               as A
 import           Data.Default
 import           Data.Foldable
@@ -6075,11 +6075,14 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d
     expectDiagnostics
       [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded
 
+    waitForProgressDone
+
     -- Change y from Int to B
     changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]
     -- save so that we can that the error propogates to A
     sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing)
 
+
     -- Check that the error propogates to A
     expectDiagnostics
       [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]
@@ -6090,7 +6093,8 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d
     hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"
     liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists
 
-    pdoc <- createDoc pPath "haskell" pSource
+    pdoc <- openDoc pPath "haskell"
+    waitForProgressDone
     changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]
     -- Now in P we have
     -- bar = x :: Int

ghcide/test/src/Development/IDE/Test.hs

@@ -83,7 +83,7 @@ expectNoMoreDiagnostics timeout =
   expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do
     let fileUri = diagsNot ^. params . uri
         actual = diagsNot ^. params . diagnostics
-    liftIO $
+    unless (actual == List []) $ liftIO $
       assertFailure $
         "Got unexpected diagnostics for " <> show fileUri
           <> " got "