clean up and revert other flakiness test changes

Author: soulomoon

ghcide-test/exe/ResolveTests.hs

@@ -24,7 +24,7 @@ import           Language.LSP.Test             hiding (resolveCompletion)
 import           Test.Hls                      (IdeState, SMethod (..), liftIO,
                                                 mkPluginTestDescriptor,
                                                 someMethodToMethodString,
-                                                waitForKickDone)
+                                                waitForAllProgressDone)
 import qualified Test.Hls.FileSystem           as FS
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -100,7 +100,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForKickDone
+      waitForAllProgressDone
       items <- getCompletions doc (Position 2 7)
       let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items
       liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems)
@@ -113,7 +113,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForKickDone
+      waitForAllProgressDone
       -- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic
       -- locations and we don't have diagnostics in these tests.
       cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0))
@@ -128,7 +128,7 @@ resolveRequests =
         , "data Foo = Foo { foo :: Int }"
         , "bar = Foo 4"
         ]
-      waitForKickDone
+      waitForAllProgressDone
       cd <- getCodeLenses doc
       let resolveCodeLenses = filter (\i -> case i ^. J.command of
             Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title)

ghcide/session-loader/Development/IDE/Session.hs

@@ -1,6 +1,5 @@
-{-# LANGUAGE CPP                #-}
-{-# LANGUAGE ImpredicativeTypes #-}
-{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE CPP          #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-|
 The logic for setting up a ghcide session by tapping into hie-bios.
@@ -119,7 +118,6 @@ import qualified System.Random                       as Random
 import           System.Random                       (RandomGen)
 import           Text.ParserCombinators.ReadP        (readP_to_S)
 
-import qualified Control.Monad.Catch                 as MC
 import           GHC.Driver.Env                      (hsc_all_home_unit_ids)
 import           GHC.Driver.Errors.Types
 import           GHC.Types.Error                     (errMsgDiagnostic,
@@ -756,7 +754,6 @@ emptyHscEnv :: NameCache -> FilePath -> IO HscEnv
 emptyHscEnv nc libDir = do
     -- We call setSessionDynFlags so that the loader is initialised
     -- We need to do this before we call initUnits.
-    -- we mask_ here because asynchronous exceptions might be swallowed
     env <- runGhc (Just libDir) $
       getSessionDynFlags >>= setSessionDynFlags >> getSession
     pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env)

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

@@ -23,30 +23,24 @@ import           Control.Concurrent.STM         (STM)
 import           Control.Concurrent.STM.Stats   (TVar, atomically,
                                                  atomicallyNamed, modifyTVar',
                                                  newTVarIO, readTVar, retry)
-import           Control.Concurrent.Strict      (modifyVar_, newBarrier, newVar,
-                                                 signalBarrier, threadDelay)
+import           Control.Concurrent.Strict      (modifyVar_, newVar,
+                                                 threadDelay)
 import           Control.Monad.Extra            hiding (loop)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      (lift)
-import qualified Data.Aeson                     as J
 import           Data.Functor                   (($>))
 import qualified Data.Text                      as T
-import           Data.Unique                    (hashUnique, newUnique)
 import           Development.IDE.GHC.Orphans    ()
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import qualified Focus
-import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.Protocol.Types    as L
-import           Language.LSP.Server            (MonadLsp, ProgressAmount (..),
+import           Language.LSP.Server            (ProgressAmount (..),
                                                  ProgressCancellable (..),
-                                                 sendNotification, sendRequest,
                                                  withProgress)
 import qualified Language.LSP.Server            as LSP
 import qualified StmContainers.Map              as STM
 import           UnliftIO                       (Async, async, bracket, cancel)
-import qualified UnliftIO.Exception             as UE
 
 data ProgressEvent
   = ProgressNewStarted
@@ -174,7 +168,7 @@ progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do
   let _progressUpdate event = liftIO $ updateStateVar $ Event event
       _progressStop = updateStateVar StopProgress
       updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done)
-  return ProgressReporting {_progressUpdate, _progressStop}
+  return ProgressReporting {..}
 
 -- | `progressReporting` initiates a new progress reporting session.
 -- It necessitates the active tracking of progress using the `inProgress` function.
@@ -202,28 +196,6 @@ progressReporting (Just lspEnv) title optProgressStyle = do
 
         f = recordProgress inProgress file
 
-withProgressDummy ::
-  forall c m a.
-  MonadLsp c m =>
-  T.Text ->
-  Maybe ProgressToken ->
-  ProgressCancellable ->
-  ((ProgressAmount -> m ()) -> m a) ->
-  m a
-withProgressDummy title _ _ f = do
-        UE.bracket start end $ \_ ->
-            f (const $ return ())
-  where
-    sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report
-    start = UE.uninterruptibleMask_ $ do
-        t <- L.ProgressToken . L.InR . T.pack . show . hashUnique <$> liftIO newUnique
-        r <- liftIO newBarrier
-        _ <- sendRequest SMethod_WindowWorkDoneProgressCreate (WorkDoneProgressCreateParams t) $ \_ -> liftIO $ signalBarrier r ()
-        sendProgressReport t $ WorkDoneProgressBegin L.AString title Nothing Nothing Nothing
-        return t
-    end t = do
-        sendProgressReport t (WorkDoneProgressEnd L.AString Nothing)
-
 -- Kill this to complete the progress session
 progressCounter ::
   LSP.LanguageContextEnv c ->
@@ -233,12 +205,8 @@ progressCounter ::
   STM Int ->
   IO ()
 progressCounter lspEnv title optProgressStyle getTodo getDone =
-    LSP.runLspT lspEnv $ withProgressChoice title Nothing NotCancellable $ \update -> loop update 0
+  LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0
   where
-    withProgressChoice = case optProgressStyle of
-        TestReporting -> withProgressDummy
-        _             -> withProgress
-
     loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound
     loop update prevPct = do
       (todo, done, nextPct) <- liftIO $ atomically $ do

ghcide/src/Development/IDE/Main.hs

@@ -77,9 +77,8 @@ import           Development.IDE.Types.Location           (NormalizedUri,
                                                            toNormalizedFilePath')
 import           Development.IDE.Types.Monitoring         (Monitoring)
 import           Development.IDE.Types.Options            (IdeGhcSession,
-                                                           IdeOptions (..),
+                                                           IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
                                                            IdeTesting (IdeTesting),
-                                                           ProgressReportingStyle (TestReporting),
                                                            clientSupportsProgress,
                                                            defaultIdeOptions,
                                                            optModifyDynFlags,
@@ -277,10 +276,7 @@ testing recorder projectRoot plugins =
       let
         defOptions = argsIdeOptions config sessionLoader
       in
-        defOptions{
-            optTesting = IdeTesting True
-            , optProgressStyle = TestReporting
-            }
+        defOptions{ optTesting = IdeTesting True }
     lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }
   in
     arguments

ghcide/src/Development/IDE/Types/Options.hs

@@ -107,7 +107,6 @@ newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling    Bool
 data ProgressReportingStyle
     = Percentage -- ^ Report using the LSP @_percentage@ field
     | Explicit   -- ^ Report using explicit 123/456 text
-    | TestReporting -- ^ Special mode for testing, reports only start/stop
     | NoProgress -- ^ Do not report any percentage
     deriving Eq
 

hls-test-utils/src/Test/Hls.hs

@@ -758,7 +758,6 @@ wrapClientLogger logger = do
     let lspLogRecorder = cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions. pretty) lspLogRecorder'
     return (lspLogRecorder <> logger, cb1)
 
-
 -- | Host a server, and run a test session on it.
 -- For setting custom timeout, set the environment variable 'LSP_TIMEOUT'
 -- * LSP_TIMEOUT=10 cabal test

plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs

@@ -66,8 +66,7 @@ import           System.Environment                                 (setEnv,
 import           Development.IDE.GHC.Compat                         (DynFlags,
                                                                      extensionFlags,
                                                                      ms_hspp_opts,
-                                                                     topDir,
-                                                                     uninterruptibleMaskM_)
+                                                                     topDir)
 import qualified Development.IDE.GHC.Compat.Util                    as EnumSet
 
 #if MIN_GHC_API_VERSION(9,4,0)
@@ -206,7 +205,7 @@ rules recorder plugin = do
 
   defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do
     (Config flags) <- getHlintConfig plugin
-    liftIO $ uninterruptibleMask_ $ argsSettings flags
+    liftIO $ argsSettings flags
 
   action $ do
     files <- Map.keys <$> getFilesOfInterestUntracked

plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs

@@ -94,7 +94,7 @@ help when a space char is inserted, we probably have to use up-to-date results.
 
 {-
 Here is a brief description of the algorithm of finding relevant bits from HIE AST
-1. let 'hsAppNode' = the smallest 'HsApp' AST node which contains the cursor postion
+1. let 'hsAppNode' = the smallest 'HsApp' AST node which contains the cursor position
    See 'extractInfoFromSmallestContainingFunctionApplicationAst'
 2. let 'functionNode' = the left-most node of 'hsAppNode'
    See 'getLeftMostNode'