soulomoon · soulomoon · Aug 21, 2025 · Aug 21, 2025 · Aug 21, 2025 · Aug 21, 2025
@@ -0,0 +1,109 @@
+name: flakiness
+
+defaults:
+  run:
+    shell: bash
+
+concurrency:
+  group: ${{ github.head_ref }}-${{ github.workflow }}
+  cancel-in-progress: true
+
+on:
+  # Run on PRs that touch relevant areas and on manual dispatch
+  pull_request:
+    branches:
+      - '**'
+    paths:
+      - 'scripts/flaky-test-loop.sh'
+      - 'scripts/flaky-test-patterns.txt'
+      - 'ghcide/**'
+      - 'ghcide-test/**'
+      - 'hls-test-utils/**'
+      - 'src/**'
+      - 'exe/**'
+      - 'plugins/**'
+      - 'cabal.project'
+      - 'stack.yaml'
+      - 'haskell-language-server.cabal'
+      - '.github/workflows/flakiness.yml'
+  workflow_dispatch:
+    inputs:
+      max_iter:
+        description: 'Maximum iterations to attempt'
+        required: false
+        default: '1000'
+      sleep_secs:
+        description: 'Seconds to sleep between iterations'
+        required: false
+        default: '0'
+      test_patterns:
+        description: 'Comma-separated Tasty patterns to run each iteration (overrides default)'
+        required: false
+        default: ''
+
+jobs:
+  loop:
+    name: Flakiness Test (broken pipe and test failures)
+    runs-on: ${{ matrix.os }}
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - ubuntu-latest
+          - macos-latest
+          # - windows-latest
+
+    steps:
+      - uses: actions/checkout@v4
+
+      - name: Setup GHC and caching
+        uses: ./.github/actions/setup-build
+        with:
+          ghc: '9.12'
+          os: ${{ runner.os }}
+
+      - name: Show cabal and GHC versions
+        run: |
+          cabal --version
+          ghc --version
+      - name: Build
+        env:
+          PATTERN_FILE: 'scripts/flaky-test-patterns.txt'
+          RUN_MODE: 'build'
+        run: HLS_TEST_EXE="$(cabal exec which hls)" bash scripts/flaky-test-loop.sh
+
+      - name: Run flakiness loop
+        id: run-loop
+        # Let this run for a while; build is done once inside the script
+        timeout-minutes: 60
+        env:
+          # Use workflow_dispatch inputs when present, else defaults
+          SLEEP_SECS: ${{ github.event.inputs.sleep_secs || '0' }}
+          LOG_STDERR: '1'
+          TEST_PATTERNS: ${{ github.event.inputs.test_patterns }}
+          PATTERN_FILE: 'scripts/flaky-test-patterns.txt'
+          NO_BUILD_ONCE: '1'
+          RUN_MODE: 'run'
+          # HLS_TEST_EXE: 'hls' # HLS_WRAPPER_TEST_EXE: 'hls-wrapper'
+        run: |
+          # Run with a sensible default of 500 iterations on PRs;
+          max_iter="${{ github.event.inputs.max_iter }}"
+          max_iter="${max_iter:-500}"
+          # copy hls to current dir so the script can find it
+          HLS_TEST_EXE="$(cabal exec which hls)" bash scripts/flaky-test-loop.sh "${max_iter}"
+          ec=$?
+          # Interpret exit codes from flaky-test-loop.sh
+          #   0 => no issues reproduced within MAX_ITER          -> pass job
+          #   1 => issue reproduced (broken pipe or test failure) -> fail job
+          #   2+ => setup/infra error                            -> fail job
+          if [[ $ec -eq 1 ]]; then
+            echo "Issue reproduced (broken pipe or test failure): failing job"
+            exit 1
+          elif [[ $ec -eq 0 ]]; then
+            echo "No issues reproduced within MAX_ITER=${max_iter}: passing"
+            exit 0
+          else
+            echo "Loop script error (exit $ec): failing"
+            exit $ec
+          fi
+
diff --git a/cabal.project b/cabal.project
@@ -56,3 +56,9 @@ if impl(ghc >= 9.11)
   allow-newer:
     cabal-install-parsers:base,
     cabal-install-parsers:time,
+
+source-repository-package
+  type: git
+  location: https://github.com/soulomoon/lsp.git
+  tag: 640c7c755bf16128e3cb19c257688aa3305ff9f5
+  subdir: lsp lsp-types lsp-test
diff --git a/ghcide-test/exe/ResolveTests.hs b/ghcide-test/exe/ResolveTests.hs
@@ -24,7 +24,7 @@ import           Language.LSP.Test             hiding (resolveCompletion)
 import           Test.Hls                      (IdeState, SMethod (..), liftIO,
                                                 mkPluginTestDescriptor,
                                                 someMethodToMethodString,
-                                                waitForAllProgressDone)
+                                                waitForKickDone)
 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"
         ]
-      waitForAllProgressDone
+      waitForKickDone
       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"
         ]
-      waitForAllProgressDone
+      waitForKickDone
       -- 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"
         ]
-      waitForAllProgressDone
+      waitForKickDone
       cd <- getCodeLenses doc
       let resolveCodeLenses = filter (\i -> case i ^. J.command of
             Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title)

@@ -1,5 +1,6 @@
-{-# LANGUAGE CPP          #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies       #-}
 
 {-|
 The logic for setting up a ghcide session by tapping into hie-bios.
@@ -104,8 +105,7 @@
 import qualified Data.Set                            as OS
 import           Database.SQLite.Simple
 import           Development.IDE.Core.Tracing        (withTrace)
-import           Development.IDE.Core.WorkerThread   (awaitRunInThread,
-                                                      withWorkerQueue)
+import           Development.IDE.Core.WorkerThread
 import qualified Development.IDE.GHC.Compat.Util     as Compat
 import           Development.IDE.Session.Diagnostics (renderCradleError)
 import           Development.IDE.Types.Shake         (WithHieDb,
@@ -119,6 +119,7 @@
 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,
@@ -149,10 +150,12 @@
   | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
   | LogHieBios HieBios.Log
   | LogSessionLoadingChanged
+  | LogSessionWorkerThread LogWorkerThread
 deriving instance Show Log
 
 instance Pretty Log where
   pretty = \case
+    LogSessionWorkerThread msg -> pretty msg
     LogNoneCradleFound path ->
       "None cradle found for" <+> pretty path <+> ", ignoring the file"
     LogSettingInitialDynFlags ->
@@ -381,8 +384,8 @@
     _ <- withWriteDbRetryable deleteMissingRealFiles
     _ <- withWriteDbRetryable garbageCollectTypeNames
 
-    runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan ->
-        withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
+    runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable))
+        $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
   where
     writer withHieDbRetryable l = do
         -- TODO: probably should let exceptions be caught/logged/handled by top level handler
@@ -415,7 +418,7 @@
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 
-loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession)
+loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession)
 loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
   let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]
   cradle_files <- newIORef []
@@ -629,7 +632,7 @@
                 [] -> error $ "GHC version could not be parsed: " <> version
                 ((runTime, _):_)
                   | compileTime == runTime -> do
                     atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
                     session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
                   | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
             -- Failure case, either a cradle error or the none cradle
@@ -753,6 +756,7 @@
 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)
@@ -896,7 +900,7 @@
            x <- map errMsgDiagnostic closure_errs
            DriverHomePackagesNotClosed us <- pure x
            pure us
        isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units
    -- Whenever we spin up a session on Linux, dynamically load libm.so.6
    -- in. We need this in case the binary is statically linked, in which
    -- case the interactive session will fail when trying to load

diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs
@@ -70,11 +70,12 @@
 import           Data.Time                                    (UTCTime (..))
 import           Data.Tuple.Extra                             (dupe)
 import           Debug.Trace
 import           Development.IDE.Core.FileStore               (resetInterfaceStore)
 import           Development.IDE.Core.Preprocessor
 import           Development.IDE.Core.ProgressReporting       (progressUpdate)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
+import           Development.IDE.Core.WorkerThread            (writeTaskQueue)
 import           Development.IDE.Core.Tracing                 (withTrace)
 import qualified Development.IDE.GHC.Compat                   as Compat
 import qualified Development.IDE.GHC.Compat                   as GHC
@@ -825,7 +826,7 @@
        tcs = tcg_tcs ts :: [TyCon]
        hie_asts = GHC.enrichHie all_binds (tmrRenamed tcm) top_ev_binds insts tcs

    pure $ Just $
 #if MIN_VERSION_ghc(9,11,0)
      hie_asts (tcg_type_env ts)
 #else
@@ -882,7 +883,7 @@
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
       modifyTVar' indexPending $ HashMap.insert srcPath hash
-      writeTQueue indexQueue $ \withHieDb -> do
+      writeTaskQueue indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
         -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do
@@ -1105,7 +1106,7 @@


        convImport (L _ i) = (
                               (ideclPkgQual i)
                             , reLoc $ ideclName i)

        msrImports = implicit_imports ++ imps

diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs
@@ -45,6 +45,7 @@ import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake                   hiding (Log)
 import qualified Development.IDE.Core.Shake                   as Shake
+import           Development.IDE.Core.WorkerThread
 import           Development.IDE.GHC.Orphans                  ()
 import           Development.IDE.Graph
 import           Development.IDE.Import.DependencyInformation
@@ -252,8 +253,8 @@ getVersionedTextDoc doc = do
     maybe (pure Nothing) getVirtualFile $
         uriToNormalizedFilePath $ toNormalizedUri uri
   let ver = case mvf of
-        Just (VirtualFile lspver _ _) -> lspver
-        Nothing                       -> 0
+        Just (VirtualFile lspver _ _ _) -> lspver
+        Nothing                         -> 0
   return (VersionedTextDocumentIdentifier uri ver)
 
 fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
@@ -304,7 +305,7 @@ typecheckParentsAction recorder nfp = do
 setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
 setSomethingModified vfs state reason actionBetweenSession = do
     -- Update database to remove any files that might have been renamed/deleted
-    atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
+    atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
     void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool

diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs
@@ -23,24 +23,30 @@ import           Control.Concurrent.STM         (STM)
 import           Control.Concurrent.STM.Stats   (TVar, atomically,
                                                  atomicallyNamed, modifyTVar',
                                                  newTVarIO, readTVar, retry)
-import           Control.Concurrent.Strict      (modifyVar_, newVar,
-                                                 threadDelay)
+import           Control.Concurrent.Strict      (modifyVar_, newBarrier, newVar,
+                                                 signalBarrier, 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           Language.LSP.Server            (ProgressAmount (..),
+import qualified Language.LSP.Protocol.Types    as L
+import           Language.LSP.Server            (MonadLsp, 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
@@ -168,7 +174,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 {..}
+  return ProgressReporting {_progressUpdate, _progressStop}
 
 -- | `progressReporting` initiates a new progress reporting session.
 -- It necessitates the active tracking of progress using the `inProgress` function.
@@ -196,6 +202,28 @@ 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 ->
@@ -205,8 +233,12 @@ progressCounter ::
   STM Int ->
   IO ()
 progressCounter lspEnv title optProgressStyle getTodo getDone =
-  LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0
+    LSP.runLspT lspEnv $ withProgressChoice 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

diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs
@@ -516,8 +516,8 @@
   vfsRef <- asks vfsVar
   vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef
   (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of
-    Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
-    Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf)
+    Just (Open vf) -> pure (virtualFileText vf, Just $ virtualFileVersion vf)
+    _ -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
   let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res
       del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource
   pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver)
@@ -809,7 +809,7 @@
            { source_version = ver
            , old_value = m_old
            , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
            , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
            , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f
            , regenerate = regenerateHiFile session f ms
            }